; acisinit.scm
;----------------------------------------------------------------------
; Purpose---
;;   This is an example startup file.  It is loaded when the
;    ACIS 3D Toolkit scheme test program is started.
;;   It will look for a file called acisinit.scm in the working directory,
;;   your home directory (defined by the environment variable HOME or the
;;   variables HOMEDRIVE and HOMEPATH, and the directories specified by the
;;   environment variable LOADPATH).  If it finds the file, it will load it
;;   and not search the remaining directories.
;----------------------------------------------------------------------

; Identify what type of system we are using, NT or UNIX.
(define NT (string=? (system:name) "NT"))
(define UNIX (not (or (string=? (system:name) "mac") (string=? (system:name) "NT"))))

; Format the output of error messages so we can easily pick them out of a journal file.
(define (error-string error-msg)
  (string-append
    (format #f "\(~s\)~%    " (car error-msg))
    (apply format #f (cdr error-msg))
    )
  )

(set! error-handler
      (lambda error-msg
        (display "*** Error ")
        (display (error-string error-msg)) (newline)
        )
      )

; Set the search path for scheme scripts.
; This depends on your A3DT environment variable being set in order
; to determine the appropriate path for all of the Scheme scripts.

(define base_path (system:getenv "A3DT"))
(if base_path
    (begin
      (define example_path (string-append base_path "/scm/examples"))
      (define schemers_path (string-append base_path "/scm/examples/schemers"))
      (set! load-path (list "." example_path schemers_path))
      )
    )

; Add paths to DS if it is available.
(if base_path
    (begin
      (define ds_path (string-append base_path "/scm/adm"))
      (define ds_demo_file (string-append ds_path "/dsdemo.scm"))
      (if (file-exists? ds_demo_file)
          (set! load-path (append load-path (list ds_path)))
          )
      )
    )

; Set the search path for ACIS SAT files.
(set! part-load-path load-path)

;; STI ROLL begin:  This option is not valid in 7.0
; Turn off distributed history
;(option:set "distributed_history" #f)
;; STI ROLL end

;(option:set "mesh_manager" "linked")

;;*********************************************************************
;; acis.scm
;;*********************************************************************
;======================================================================
; Purpose---
;    Useful scheme procedures for running the ACIS 3D Toolkit
;
;======================================================================

(provide 'acis)

;; Useful aliases for #t and #f
(define ON #t)
(define OFF #f)

;;----------------------------------------------------------------------
;; The variable print-length controls printing of lists.  This command
;; causes only the first 20 elements of a list to be printed. Modified
;; to print everything.
(set! print-length -1)

;;----------------------------------------------------------------------
;; Supress notification when garbage collecting is done.
(set! garbage-collect-notify? #f)

;;----------------------------------------------------------------------

(define list-print (lambda (in_list) (begin (map (lambda (x) (print x)) in_list) (length in_list))))
(define pick-print (lambda (in_list) (map (lambda (x) (display (entity:debug (car x))) (print x)) in_list)))

;;----------------------------------------------------------------------
(define zoom
  (lambda (zoom-scale . v)
    (let ((view (if (not (null? v)) (car v) (env:active-view)))
          (scale (max .001 zoom-scale))
          )
      (view:set-size (/ (view:width view) scale)
                     (/ (view:height view) scale)
                     view)
      (view:refresh view)
      )))

;; Zoom in on a window
(define (zoom-window) (let ((w (get-window)))
                        (view:refresh (view:zoom-window (car w) (cdr w)))))

(define (zoom-all . v)
  (let ((view (if (not (null? v)) (car v) (env:active-view))))
    (view:compute-extrema view)
    (view:set-size (* (view:width view) 1.05)
                   (* (view:height view) 1.05)
                   view)
    (view:refresh view)
    ))

(define zoom-pos (lambda ()
    (let (  (view (env:active-view))
            (ent #f)
            (pos #f)
        )
        (if view
            (let* ( (pr (read-ray))
                    (target_pos (pick:entity-position pr))
                )
                (if (not (or (eq? target_pos #f) (eq? target_pos '())))
                    (
                        (view:set-eye eye_pos) (view:set-target target_pos) 
                        (view:refresh)
                    )
                    (print "No entity picked")
                )
            )
            (begin
                (print "No view opened")
            )
        )
        (list ent pos)
    )
))

(define zoom-entity (lambda ( ent )
                      (let*    ( (view (env:active-view)) )
                        (if ent
                            (begin
                              (if (vertex? ent)
                                  (begin
                                    (define pos0 (vertex:position ent)))
                                  (begin
                                    (define pos0 (car (entity:box ent)))))
                              (define x0 (position:x pos0))
                              (define y0 (position:y pos0))
                              (define z0 (position:z pos0))
                              (if (vertex? ent)
                                  (begin
                                    (define pos1 (vertex:position ent)))
                                  (begin
                                    (define pos1 (cdr (entity:box ent)))))
                              (define x1 (position:x pos1))
                              (define y1 (position:y pos1))
                              (define z1 (position:z pos1))
                              (define center (position (/ (+ x0 x1) 2) (/ (+ y0 y1) 2)  (/ (+ z0 z1) 2)))
                              (view:set-target center view)
                              (define diag  (position:distance pos0 pos1))
                              (view:set-size (* diag 1.05) (* diag 1.05) view)
                              (view:refresh view)
                              )
                            (begin
                              (display "No entity picked")
                              (newline)
                              )
                            )
                        ent
                        )
                      ))

(define pick-ents (lambda ()
    (define ret_list '())
    (rbd:push rb-ray)
    (let* ( (pr (read-ray)) )
        (set! ret_list (pick:ents pr ))
    )
    (rbd:pop)
    ret_list
) )

(define pick-ents-rb (lambda ()
    (rbd:push rb-ray)
    (define ret_list (pick:ents (read-ray) (+ 0.0 (option:get 'raysize)))) 
    (rbd:pop)
    ;(pick-print res) 
    ret_list
) )

(define pick-ents-rb-list (lambda ()
    (define pick_list (pick-ents-rb))
    (if (< 0 (length pick_list))
        (pick-print pick_list)
    )
) )

;;*********************************************************************
;; apropos.scm
;;*********************************************************************

;----------------------------------------------------------------------
; Find scheme procedures whose name includes a given string.
; For example, to find all procedures which include the word "curve"
; issue the command (apropos "curve")
;----------------------------------------------------------------------

(provide 'apropos)

(define apropos)
(define o-apropos)

(define (string:remove-char str ch) 
    (define len (string-length str))
    (define sop (open-output-string))
    (do ((i 0 (1+ i))) ((= i len))
        (if (not (char=? (string-ref str i) ch))
            (write-char (string-ref str i) sop)))
    (get-output-string sop)
)

(let ((patterns) (pat_count) (found))
    
    (define (arg->string what)
        (case (type what)
            (symbol 
                (symbol->string what))
            (string 
                what)
            (else
                (error 'apropos "string or symbol expected"))))
    
    ;; Curretly we are not supporting regex. So just create the 
    ;; list of strings from passed args.
    
    (define (make-str-patterns args)
        (set! patterns (map arg->string args))
        (set! pat_count (length patterns)))
    
    (define (match-str-patterns str)
        (define matched (> pat_count 0))
        (do ((i 0 (+ i 1))) ((or (= i pat_count) (not matched)))
            (set! matched (substring? (list-ref patterns i) str)))
        matched)
    
    ;; Utility function
        
    (define (got-one res) 
        (set! found (1+ found))
        (print res))

    (define (got-symbol sym) 
        (if (bound? sym) (got-one sym)))
    
    (define (init-variables)
        (set! patterns (list))
        (set! pat_count 0)
        (set! found 0))
    
    (define (print-results)
        (if (= found 0)
            (format #t "$$$ ~a: nothing appropriate~%" patterns)
            (format #t "$$$ ~a: ~a Results~%" patterns found)))
            
    ;; Main function 
    (set! apropos (lambda ( . args)
        (init-variables)
        (make-str-patterns args)
        (do ((tail (oblist) (cdr tail))) ((null? tail))
            (do ((l (car tail) (cdr l))) ((null? l))
                (if (match-str-patterns (symbol->string (car l)))
                    (got-symbol (car l)))))
        (print-results)
        found))

    ; Again, but for the option:list instead of oblist
  
    (set! o-apropos (lambda ( . args)
        (init-variables)
        (make-str-patterns args)    
        (do ((tail (option:list) (cdr tail))) ((null? tail))
            (if (match-str-patterns (string:remove-char (caar tail) '#\#)) ;slow but '# independent
            ;(if (match-str-patterns (caar tail)) ; fast but '# dependent.
                (got-one (car tail))))
        (print-results)
        found))
)

;;*********************************************************************
;; Colors.scm
;;*********************************************************************

;======================================================================
; Purpose---
;    Define names for standard colors
;
;======================================================================

(provide 'colors)

(define BLACK 0)
(define RED 1)
(define GREEN 2)
(define BLUE 3)
(define CYAN 4)
(define YELLOW 5)
(define MAGENTA 6)
(define WHITE 7)

(define rgb:red     (color:rgb 1 0 0))
(define rgb:green   (color:rgb 0 1 0))
(define rgb:blue    (color:rgb 0 0 1))
(define rgb:yellow  (color:rgb 1 1 0))
(define rgb:magenta (color:rgb 1 0 1))
(define rgb:cyan    (color:rgb 0 1 1))
(define rgb:black   (color:rgb 0 0 0))
(define rgb:white   (color:rgb 1 1 1))
(define rgb:orange  (color:rgb (/ 255 255) (/ 136 255) (/ 100 255)))
(define rgb:brown   (color:rgb (/ 175 255) (/  89 255) (/  62 255)))

;;*********************************************************************
;; describe.scm
;;*********************************************************************
;----------------------------------------------------------------------
; Describe a scheme object
;----------------------------------------------------------------------

(provide 'describe)

(define (describe x)
  (fluid-let
    ((print-depth 2)
     (print-length 3))
    (format #t "~s is " (if (eq? x #v) '\#v x)))
  (case (type x)
    (integer
      (format #t "an integer.~%"))
    (real
      (format #t "a real.~%"))
    (null
      (format #t "an empty list.~%"))
    (boolean
      (format #t "a boolean value (~s).~%" (if x 'true 'false)))
    (character
      (format #t "a character, ascii value is ~s~%" (char->integer x)))
    (symbol
      (format #t "a symbol.")
      (let ((l (symbol-plist x)))
        (if (null? l)
            (format #t "  It has no property list.~%")
            (format #t "~%Its property list is: ~s.~%" l))))
    (pair
      (if (pair? (cdr x))
          (let ((p (last-pair x)))
            (if (null? (cdr p))
                (format #t "a list of length ~s.~%" (length x))
                (format #t "an improper list.~%")))
          (format #t "a pair (cons cell).~%")))
    (environment
      (format #t "an environment.~%"))
    (string
      (if (eqv? x "")
          (format #t "an empty string.~%")
          (format #t "a string of length ~s.~%" (string-length x))))
    (vector
      (if (eqv? x '#())
          (format #t "an empty vector.~%")
          (if (and (feature? 'oops) (memq (vector-ref x 0)
                                          '(class instance)))
              (if (eq? (vector-ref x 0) 'class)
                  (begin
                    (format #t "a class.~%~%")
                    (describe-class x))
                  (format #t "an instance.~%~%")
                  (describe-instance x))
              (format #t "a vector of length ~s.~%" (vector-length x)))))
    (primitive
      (format #t "a primitive procedure.~%"))
    (compound
      (format #t "a compound procedure (type ~s).~%"
              (car (procedure-lambda x))))
    (control-point
      (format #t "a control point (continuation).~%"))
    (promise
      (format #t "a promise.~%"))
    (port
      (format #t "a port.~%"))
    (end-of-file
      (format #t "the end-of-file object.~%"))
    (macro
      (format #t "a macro.~%"))
    (entity
      (format #t "an entity of type ~s~%" (entity:debug x)))
    (position
      (format #t "a position.~%"))
    (gvector
      (format #t "an ACIS vector.~%"))
    (view
      (format #t "a view. ~%"))
    (color
      (format #t "a color. ~%"))
    (curve
      (format #t "a curve. ~%"))
    (else
      (let ((descr-func (string->symbol
                          (format #f "describe-~s" (type x)))))
        (if (bound? descr-func)
            ((eval descr-func) x)
            (format #t "an object of unknown type (~s)~%" (type x)))))))

;;*********************************************************************
;; Lister.scm
;;*********************************************************************

(provide 'lister)

;;(part:names) returns the list of entities in the part that have names
;; (i.e., ones that have symbols defined for them in the environment)

(define part:names
  (lambda ()
    (letrec ((return_list '()))                ;; start a return list
      (let loop ((e_list (environment->list (the-environment))))
        (if (not (null? e_list))  ;; if the list is not null
            (if (symbol? (car e_list))  ;;and the first part is a symbol
                (if (entity? (cdr e_list))  ;;and the second part is an ent
                    (begin ;; check to see if it is already in the return list
                      (if (not (member (cdr e_list) return_list))
                          (set! return_list (cons (cdr e_list) return_list)))
                      (format #t "  ~a      \t~a  \t~a~%" (car e_list)  (entity:debug (cdr e_list)) (cdr e_list)))) ;; print out he pertinent info
                (begin ;; if the first part is not a symbol
                  (loop (car e_list)) ;; call loop in it
                  (loop (cdr e_list)))))) ;; then call loop on the rest of list
      return_list))) ;; return the list of all entities which have names


;;(part:list) is somewhat analagous to the Test Harness list command:
;;  it lists all entities which have names, then lists those entities
;;  that do not, for a complete listing of all entities in the part.
;;  It returns the empty list.
(define part:list
  (lambda ()
    (letrec ((p_list (part:entities));;create the return list
             (return_list '()))
      (let loop ((e_list (environment->list (the-environment))))
        (if (not (null? e_list)) ;; if list is not null
            (if (symbol? (car e_list)) ;; and first part is a symbol
                (if (entity? (cdr e_list)) ;; and second part is an entity
                    (begin ;; remember this entity for later use
                      (set! return_list (cons (cdr e_list) return_list))
                      (format #t "  ~a      \t~a  \t~a~%" (car e_list)  (entity:debug (cdr e_list)) (cdr e_list))));; print out pertinent info
                (begin ;; if first part is not a symbol
                  (loop (car e_list)) ;; loop with first part
                  (loop (cdr e_list)))))) ;; loop with second part
      ;;at this point, all named entities have been listed
      ;;now we look at those without names
      (let loop2 ((p_list (part:entities)));; start off with all entities
        (if (not (null? p_list)) ;; if entity list not null
            (let ((in (member (car p_list) return_list)))
              (if in  ;; if the first of ents is in the return list
                  (loop2 (cdr p_list));; continue with rest
                  (begin
                    (format #t "(no name)   \t~a  \t~a~%" (entity:debug (car p_list)) (car p_list))
                    (loop2 (cdr p_list)))))
            ;;else remember this element and do the rest
            )))))

(define env:bools
  (lambda ()
    (let loop ((e_list (environment->list (the-environment))))
      (if (not (null? e_list))
          (if (symbol? (car e_list))
              (if (boolean? (cdr e_list))
                  (format #t "  ~a   ~a~%" (car e_list) (cdr e_list)))
              (begin
                (loop (car e_list))
                (loop (cdr e_list))))))))

;;*********************************************************************
;; Math.scm
;;*********************************************************************
;----------------------------------------------------------------------
; Define basic math values and procedures.
;----------------------------------------------------------------------

(provide 'math)

(define PI 3.14159265358979323846)
(define PI/2 1.57079632679489661923)
(define (degrees->radians a) (* a 0.0174532925199433))
(define (radians->degrees a) (* a 57.2957795130823))

;; Raise a number to an integer power
(define (expt x n)
  (if (integer? n)
      (let power ((num x)
                  (pow n)
                  (answer 1)
                  )
        (cond
          ((< pow 0) (/ 1 (power num (abs pow) answer)))
          ((= pow 0) answer)
          ((= pow 1) (* answer num))
          ((even? pow) (power (* num num) (/ pow 2) answer))
          (else (power num (- pow 1) (* answer num)))
          ))
      (exp (* n (log x)))
      ))


;;*********************************************************************
;; Old-rb.scm
;;*********************************************************************
;======================================================================
; Purpose---
;    Implement old rubberbanding interface on top of new one.
;======================================================================

(provide 'old-rb)

;; Define the hooks.  rb-position-hook is still hard coded.
(define rb-start-hook #f)
(define rb-update-hook #f)
(define rb-stop-hook #f)
(define rb-repaint-hook #f)
(define rb-init-hook #f)
(define rb-end-hook #f)

;; Redefine the old primitives as compounds in terms of the new primitives.
(define rb:clear rbd:clear)
(define rb:push  rbd:push)
(define rb:pop   rbd:pop)

;; Args are a list of entity list and a start position passed as
;; ((ent1 ent2 ...) position)
;; Both arguments are optional, tho dragging no entities doesn't make
;; much sense.  That is how the old rb interface worked.
(define (rb:drag onoff . args)
  (if onoff
      (if (pair? args)
          (rbd:drag #t (car args) (cadr args))
          (rbd:drag #t args))
      (rbd:remove-type rbd:drag?)))

(define (rb:generic onoff)
  (if onoff
      (rbd:generic #t)
      (rbd:remove-type rbd:generic?)))

(define (rb:line onoff . base-pos)
  (if onoff
      (if (pair? base-pos)
          (rbd:line #t (car base-pos))
          (rbd:line #t))
      (rbd:remove-type rbd:line?)))

(define (rb:rectangle onoff . base-pos)
  (if onoff
      (if (pair? base-pos)
          (rbd:rectangle #t (car base-pos))
          (rbd:rectangle #t))
      (rbd:remove-type rbd:rectangle?)))

; The old style rb:scheme used global hook functions.  The new style
; passes hook functions as a vector.  In order for the hooks to know
; which rbd:scheme they are being called on behalf of, an rbd:scheme is
; passed as the first argument.  Here we create a vector of lambda expressions
; that ignore the first argument and pass remaining args on to the old
; style global hooks.
(define (hook-vector)
  (vector
    (if (procedure? rb-init-hook) (lambda (self . args) (if (eqv? args '()) (rb-init-hook) (rb-init-hook args))) #f)
    (if (procedure? rb-start-hook) (lambda (self pe) (rb-start-hook pe)) #f)
    (if (procedure? rb-update-hook) (lambda (self pe) (rb-update-hook pe)) #f)
    (if (procedure? rb-stop-hook) (lambda (self) (rb-stop-hook)) #f)
    (if (procedure? rb-repaint-hook) (lambda (self view) (rb-repaint-hook view)) #f)
    (if (procedure? rb-position-hook) (lambda (self pe) (rb-position-hook pe)) #f)
    (if (procedure? rb-end-hook) (lambda (self) (rb-end-hook)) #f)))

(define (rb:scheme onoff . args)
  (if onoff
      (if (pair? args)
          (rbd:scheme #t (hook-vector) (car args))
          (rbd:scheme #t (hook-vector)))
      (rbd:remove-type rbd:scheme?)))

(define (rb:window onoff . base-evt)
  (if onoff
      (if (pair? base-evt)
          (rbd:window #t (car base-evt))
          (rbd:window #t))
      (rbd:remove-type rbd:window?)))

;;*********************************************************************
;; Pick.scm
;;*********************************************************************
;======================================================================
; Purpose---
;    Define procedures for picking and highlighting entities
;
;======================================================================

(provide 'pick)

;; Flash-Time is the time in milliseconds that flash will highlight entities
(define Flash-Time 200)
;; flash is used to highlight an entity or list of entities.

;; Test to see if an object is either an entity or an entray
(define (entity-or-entray? e) (or (entity? e) (entray? e)))

;; Test to see if an object is a list of entities
(define (entity-list? o)
  (if (and (list? o) (not (null? o)))
      (let loop ((l o))
        (cond
          ((null? l) #t)
          ((entity-or-entray? (car l)) (loop (cdr l)))
          (else #f)
          )
        )
      #f
      )
  )

;; Highlight an entity or list of entities or component entity for a short time
(define flash
  (lambda (e)
    (if (or (entity-or-entray? e) (entity-list? e))
        (begin
          (entity:set-highlight e #t)
          (system:sleep Flash-Time)
          (entity:set-highlight e #f)
          ))
    (if (component-entity? e)
        (begin
          (component-entity:set-highlight e #t)
          (system:sleep Flash-Time)
          (component-entity:set-highlight e #f)
          ))
    (if (point-cloud? e)
        (begin
          (point-cloud:set-highlight e #t)
          (system:sleep Flash-Time)
          (point-cloud:set-highlight e #f)
          ))
    e))

;; Define some stuff to make picking easier

(define pick:vertex-or-point
  (lambda (evt . filt)
    (let ((ent (apply pick:vertex evt filt)))
      (if (vertex? ent)
          ent
          (let ((pfilt (apply filter:and (filter:type "point?") filt)))
            (pick:entity evt pfilt))))))

(define pick:entity-position
  (lambda (evt . filt)
    (let ((v (apply pick:vertex-or-point evt filt)))
      (cond
        ((vertex? v) (vertex:position v))
        ((point? v) (point:position v))
        (else #f)
        ))))

(define pick:entity-with-ray
  (lambda (evt . filt)
    (let ((r (pick:ray evt))
          (e (apply pick:entity evt filt))
          )
      (entray e r)
      )))

(define pick:edge-with-ray
  (lambda (r . filt)
    (let ((e (apply pick:edge r filt))
          )
      (entray e r)
      )))


(define (get-window) (let* ((p1 (read-event))
                            (p2 (begin
                                  (rbd:window #t p1)
                                  (read-event))))
                       (rbd:remove-type rbd:window?)
                       (cons p1 p2)))

(define (draw-circle center radius cur-view)
  (if cur-view
      (let* ((sides 20)
             ;; Define a vector to contain the vertex positions
             (points (make-vector (+ sides 1) (position 0 0 0)))
             ;; Compute transformation from one vertex to the next
             (normal (gvector:unitize (gvector:from-to (view:eye) (view:target))))
             (trans (transform:rotation center normal (/ 360 sides)))
             ; Start radius from the center
             (pos (position:offset center (gvector:scale (gvector:unitize (view:up)) radius))))
        (begin
          ;; Set the positions in a do loop
          (vector-set! points 0 (position:copy pos))
          (vector-set! points sides (position:copy pos))
          (do ((i 1 (+ i 1)))
              ((= i sides))
              (vector-set! points i
                           (position:transform (vector-ref points (- i 1))
                                               trans)
                           ))
          (view:draw-polyline points cur-view)))))

(define (rb-radius_clip radius view)
    (define maxrad (/ (view:width view) 2))
    (define minrad (* 1 (/ (view:width view) (caddr (view:viewport view)))) ) ; 1 * size of 1 pixel in world coords
    (if (> radius maxrad) (set! radius maxrad) )
    (if (< radius minrad) (set! radius minrad) )
    radius
)

(define rb-ray-start-hook
  (lambda (self pe)
    (let* ((view (event:view pe))
           (pos (pick:position pe))
           (radius (option:get "raysize")))
      (begin
        (define rs (option:get "raysize"))
        (set! rs (rb-radius_clip rs view))
        (set! radius rs)
        (option:set 'raysize rs)
        (view:set-rb-mode #t view)
        (draw-circle pos radius view)
        (view:set-rb-mode #f view)
        (rbd:scheme-set-local self 0 pos)
        (rbd:scheme-set-local self 1 radius)
        (rbd:scheme-set-local self 2 view)
      ))))

(define rb-ray-adjust-raysize
  (lambda (pe old-radius old-pos new-pos)
    (if (event:shift? pe)
    (begin
      (define oldpos2D (car (view:convert-coords old-pos)))
      (define newpos2D (car (view:convert-coords new-pos)))
      (define old_hash (+ (par-pos:u oldpos2D) (par-pos:v oldpos2D)))
      (define new_hash (+ (par-pos:u newpos2D) (par-pos:v newpos2D)))
      (cond
        ((< old_hash new_hash)
          (begin
            (define new_val (* old-radius 1.1))
            (set! new_val (rb-radius_clip new_val (event:view pe)))
            (option:set 'raysize new_val)
            (option:get 'raysize)
          )
        )
        ((> old_hash new_hash)
          (begin
            (define new_val (* old-radius .9))
            (set! new_val (rb-radius_clip new_val (event:view pe)))
            (option:set 'raysize new_val)
            (option:get 'raysize)
          )
        )
        (else old-radius))
    )
    old-radius)))

(define rb-ray-update-hook
  (lambda (self pe)
    (let* ((old-pos (rbd:scheme-get-local self 0))
           (old-radius (rbd:scheme-get-local self 1))
           (old-view (rbd:scheme-get-local self 2))
           (new-view (event:view pe))
           (new-pos (pick:position pe))
           (new-radius (rb-ray-adjust-raysize pe old-radius old-pos new-pos)))
      (begin
        (view:set-rb-mode #t old-view)
        (draw-circle old-pos old-radius old-view)
        (view:set-rb-mode #f old-view)
        (view:set-rb-mode #t new-view)
        (draw-circle new-pos new-radius new-view)
        (view:set-rb-mode #f new-view)
        (rbd:scheme-set-local self 0 new-pos)
        (rbd:scheme-set-local self 1 new-radius)
        (rbd:scheme-set-local self 2 new-view))
    )
  )
)

(define rb-ray-stop-hook
  (lambda (self)
    (let* ((old-pos (rbd:scheme-get-local self 0))
           (old-radius (rbd:scheme-get-local self 1))
           (old-view (rbd:scheme-get-local self 2)))
      (begin
        (view:set-rb-mode #t old-view)
        (draw-circle old-pos old-radius old-view)
        (view:set-rb-mode #f old-view)))))

(define rb-ray-repaint-hook
  (lambda (self view)
    (let* ((old-pos (rbd:scheme-get-local self 0))
           (old-radius (rbd:scheme-get-local self 1))
           (old-view (rbd:scheme-get-local self 2)))
      (if (eqv? view old-view)
          (begin
            (view:set-rb-mode #t old-view)
            (draw-circle old-pos old-radius old-view)
            (view:set-rb-mode #f old-view))))))

(define rb-ray-hook-vector
  (vector                               ;Hooks
    ; 0 Init-Hook
    #f;(lambda (self))
    ; 1 Start-Hook
    rb-ray-start-hook           ; (lambda (self pe))
    ; 2 Update-Hook
    rb-ray-update-hook       ;(lambda (self pe))
    ; 3 Stop-Hook
    rb-ray-stop-hook          ;(lambda (self))
    ; 4 Repaint-Hook
    rb-ray-repaint-hook
    ; 5 Position-Hook
    #f;(lambda (self pe))
    ; 6 End-Hook
    #f;(lambda (self))
    ))

; A rubberbander to display the pick-ray as a circle and adjust it if  Shift is pressed
(define rb-ray
  (rbd:scheme #f
              rb-ray-hook-vector
              (make-vector 3)            ; Locals
              )
  )

(define rb-highlight-pick-update-hook
  (lambda (self pe)
    (let* ((pick-proc (rbd:scheme-get-local self 0))
           (filter (rbd:scheme-get-local self 1))
           (old-ent (rbd:scheme-get-local self 2))
           (new-ent (apply pick-proc (event:ray pe) filter)))
      (begin
        (rbd:scheme-set-local self 2 new-ent)
        (if (entity? new-ent)
            (if (not (eqv? old-ent new-ent))
                (begin
                  ;(format #t "Updating Highlight from ~a to ~a ~%" old-ent new-ent)
                  (entity:set-highlight new-ent #t)
                  (if (entity? old-ent) (entity:set-highlight old-ent #f))))
            (if (entity? old-ent) (entity:set-highlight old-ent #f)))
        (if (component-entity? new-ent)
            (if (not (eqv? old-ent new-ent))
                (begin
                  ;(format #t "Updating Highlight from ~a to ~a ~%" old-ent new-ent)
                  (component-entity:set-highlight new-ent #t)
                  (if (component-entity? old-ent) (component-entity:set-highlight old-ent #f))))
            (if (component-entity? old-ent) (component-entity:set-highlight old-ent #f)))))))

(define rb-highlight-pick-hook-vector
  (vector                               ;Hooks
    ; 0 Init-Hook
    #f;(lambda (self))
    ; 1 Start-Hook
    #f ; (lambda (self pe))
    ; 2 Update-Hook
    rb-highlight-pick-update-hook      ;(lambda (self pe))
    ; 3 Stop-Hook
    #f ;(lambda (self))
    ; 4 Repaint-Hook
    #f; (lambda (self view))
    ; 5 Position-Hook
    #f;(lambda (self pe))
    ; 6 End-Hook
    #f;(lambda (self))
    ))

; A rubberbander to highlight what would be picked if the left button pressed now
(define rb-highlight-pick
  (lambda (pick-proc filter)
    (rbd:scheme #f
                rb-highlight-pick-hook-vector
                (vector pick-proc filter #f)
                )
    )
  )

(define highlight-picks #f)

;; This procedure creates a procedure for interactively picking something
;; The procedure returned will take one optional argument which is a
;; pick filter
(define (make-pick-proc pick-proc)
  (lambda filter
    (begin
      (rbd:push rb-ray)
      (if highlight-picks (rbd:add (rb-highlight-pick pick-proc filter)))
      (define loop_limit 10)
      (let ((ent (let loop ((evt (read-ray)))
                   (if (ray:valid? evt)
                       (let ((ent (apply pick-proc evt filter)))
                         (cond
                           ((entity? ent) (flash ent)ent)
                           ((entray? ent) (flash (entray:entity ent)) ent)
                           ((component-entity? ent) (flash (component-entity:entity ent)) ent)
                           (else
                             (system:bell)
                             (display "Pick missed... ")
                             (set! loop_limit (- loop_limit 1))
                             (if (> loop_limit 0)
                               (loop (read-ray))
                               (display "\nLimit of 10 pick attempts reached.\n")
                             )
                             )))
                       #f))))
        (begin
          (rbd:pop)
          ent)))))
  
(define pick (make-pick-proc pick:entity))
(define pick-edge (make-pick-proc pick:edge))
(define pick-vertex (make-pick-proc pick:vertex-or-point))
(define pickr (make-pick-proc pick:entity-with-ray))
(define pick-edger (make-pick-proc pick:edge-with-ray))
(define (pick-region . filter)
  (let ((w (get-window)))
    (flash (apply pick:in-region (car w) (cdr w) filter))))


(define (pick-vertices) (pick-region (filter:type 'vertex?)))
(define (pick-edges) (pick-region (filter:type 'edge?)))
(define (pick-faces) (pick-region (filter:type 'face?)))

;; point cloud support begin
(define (make-event-pick-proc pick-proc)
  (lambda ()
    (begin
      (rbd:push rb-ray)
      (if highlight-picks (rbd:add (rb-highlight-pick pick-proc)))
      (define loop_limit 10)
      (let ((ent (let loop ((evt (read-event)))
                   (if (event:left? evt)
                       (let ((ent (pick-proc evt)))
                         (cond
                           ((point-cloud? ent) (flash ent) ent)
                           (else
                             (system:bell)
                             (display "Miss! ... ")
                             (set! loop_limit (- loop_limit 1))
                             (if (> loop_limit 0)
                               (loop (read-ray))
                               (display "\nLimit of 10 pick attempts reached.\n")
                             )
                             )))
                       #f))))
        (begin
          (rbd:pop)
          ent)))))


(if (bound? 'point-cloud:pick) (define pick-cloud (make-event-pick-proc point-cloud:pick)))
(if (bound? 'point-cloud:pick-marker) (define pick-marker (make-event-pick-proc point-cloud:pick-marker)))
(if (bound? 'point-cloud:pick-markers) (define (pick-markers) (let ((w (get-window))) (flash (point-cloud:pick-markers (car w) (cdr w))))))
;; point cloud support end

  
(define (pick-face . args)
  (begin
    (rbd:push rb-ray)
    (if (null? args)
        (if highlight-picks (rbd:add (rb-highlight-pick pick:face '(1))))
        (if highlight-picks (rbd:add (rb-highlight-pick pick:face args))))
    (let* ((ent
             (if (null? args)
                 (flash (pick:face (read-ray) 1))
                 (flash (apply pick:face (read-ray) args))
                 )))
      (begin
        (rbd:pop)
        ent))))
  
(define (pick-loop) (let ((e1 (pick-edge))
                          (e2 (pick-edge))
                          )
                      (flash (loop:find e1 e2))))
  
(define (pick-cell . args)
  (if (or (null? args) (< (car args) 2))
      (flash (cell:find (pick:face (read-ray) 1)))
      (flash
        (let ((re (read-ray))) (cell:find (pick:face re (car args)) (pick:face re (- (car args) 1))))
        )
      ))
  
(define (pick-chain) (flash (edge:chain (pick-edge))))
  
;; assembly picking
(define pick-asm-edge (make-pick-proc pick-asm:edge))
(define pick-asm-vertex (make-pick-proc pick-asm:vertex))
(define (pick-asm-face . args)
  (begin
    (rbd:push rb-ray)
    (if (null? args)
        (if highlight-picks (rbd:add (rb-highlight-pick pick-asm:face '(1))))
        (if highlight-picks (rbd:add (rb-highlight-pick pick-asm:face args))))
    (let* ((ent
             (if (null? args)
                 (flash (pick-asm:face (read-ray) 1))
                 (flash (apply pick-asm:face (read-ray) args))
                 )))
      (begin
        (rbd:pop)
        ent))))
  
  ;; Some shortcuts for getting positions
(define (~p)
  (let ((evt (read-ray)))
    (if (ray:valid? evt)
        (pick:position evt)
        #f)))
  
  ;; end point of curve
(define (~e) (let ((v (pick-vertex)))
               (cond
                 ((vertex? v) (vertex:position v))
                 ((point? v) (point:position v))
                 (else #f))))
  
  ;; mid point of curve
(define (~m)
  (let ((crv (pick-edge)))
    (if (edge? crv) (curve:eval-pos crv .5) #f)))
  
  ;; closest point on curve
(define (~c)
  (let ((eray (pick-edger)))
    (if (and (entray? eray) (edge? (entray:entity eray)))
        (car (curve:ray-pos eray))
        #f)))
  
  ;; Get a position using rectangle rubberbanding
(define ~rrp (lambda (p)
               (let ((pt))
                 (rbd:rectangle #t p)
                 (set! pt (~p))
                 (rbd:remove-type rbd:rectangle?)
                 pt)))
  
  ;; pick a list of ENTITYs
(define (general-pick-list pick-proc . filter)
  (let loop ((evt (read-event))
             (elist '()))
    (if (event:right? evt)
        (begin
          (entity:set-highlight elist #f)
          (reverse elist)
          )
        (let ((ent (apply pick-proc evt filter)))
          (if (entity-or-entray? ent)
              (begin
                (entity:set-highlight ent #t)
                (loop (read-event) (cons ent elist))
                )
              (begin
                (system:bell)
                (display "Missed! Try again... ")
                (loop (read-event) elist)
                ))))))
  
(define (get-pick-list . filter)
  (apply general-pick-list pick:entity filter))
(define (get-edge-list . filter)
  (apply general-pick-list pick:edge filter))
(define (get-face-list . filter)
  (apply general-pick-list pick:face 1 filter))
(define (get-pickr-list . filter)
  (apply general-pick-list pick:edge-with-ray filter))
  
  ;; pick a list of positions
(define (get-pos-list)
  (let loop ((evt (read-event))
             (poslist '())
             )
    (if (event:left? evt)
        (loop (read-event) (cons (pick:position evt) poslist))
        (reverse poslist)
        )))
  
  ;; pick a coedge by first picking a face and then an associated edge
(define pick-a-face
  (lambda ()
    (display "Pick a face\n")
    (pick-face)))
  
(define pick-an-edge
  (lambda ()
    (display "Pick an edge\n")
    (pick-edge)))
  
(define find-in-entity-list
  (lambda (entity-list this-entity)
    (if (and (entity-list? entity-list) (> (length entity-list ) 0) (entity? this-entity))
        (let ((found #f))
          (do ((i (- (length entity-list) 1) (- i 1)))
              ((or (< i 0) found) found)
              (if (equal? (list-ref entity-list i) this-entity)
                  (set! found (list-ref entity-list i) ))))
        (display "Invalid parameters passed to find-in-entity-list\n"))))
  
(define match-entity
  (lambda (entity-list1 entity-list2)
    (if (and (entity-list? entity-list1) (> (length entity-list1 ) 0) (entity-list? entity-list2) (> (length entity-list2 ) 0) )
        (let ((found #f))
          (do ((i (- (length entity-list2) 1) (- i 1)))
              ((or (< i 0) found) found)
              (set! found (find-in-entity-list entity-list1 (list-ref entity-list2 i)))))
        (display "Invalid parameters passed to find-in-entity-list\n"))))
  
(define pick-coedge
  (lambda ()
    (let ((picked-face (pick-a-face))
          (picked-edge (pick-an-edge)))
      (if (entity? picked-face)
          (if (entity? picked-edge)
              (let ((loop (entity:coedges picked-face))
                    (coedges (entity:coedges picked-edge)))
                (match-entity loop coedges))
              (display "Edge not picked\n"))
          (display "Face not picked\n")))))
  
;;*********************************************************************
;; Setview.scm
;;*********************************************************************
;======================================================================
; Purpose---
;    Define procedures for setting standard views
;======================================================================

(provide 'setview)

;; view control

(define make-view-proc
  (lambda (dx dy dz ux uy uz)
    (let ((dir (gvector dx dy dz "model"))
          (up (gvector ux uy uz "model")))
      (lambda v
        (let ((view (if (not (null? v)) (car v) (env:active-view))))
          (let* ((target (view:target view))
                 (distance (position:distance target (view:eye view)))
                 (eye (position:offset
                        target
                        (gvector:scale (gvector:unitize dir) distance)))
                 )
            (view:set eye target up view)
            (view:refresh view)
            ))))))

(define iso (make-view-proc 1 -2 1 0 0 1))
(define top (make-view-proc 0 0 1 0 1 0))
(define bottom (make-view-proc 0 0 -1 0 1 0))
(define front (make-view-proc 0 -1 0 0 0 1))
(define back (make-view-proc 0 1 0 0 0 1))
(define right (make-view-proc 1 0 0 0 0 1))
(define left (make-view-proc -1 0 0 0 0 1))

(define (repaint)
  (for-each view:refresh (env:views)))

;; This procedure will re-center the view so that the "center"
;; of the model is the view target position
(define (recenter-view . v)
  (let ((view (if (not (null? v)) (car v) (env:active-view))))
    (let* ((box (entity:box (part:entities (view:part view))))
           (center (position:interpolate (car box) (cdr box) .5))
           (dir (gvector:from-to (view:target view) (view:eye view)))
           )
      (view:set-target center view)
      (view:set-eye (position:offset (view:target view) dir))
      (view:refresh view)
      )))

;;*********************************************************************
;; Testload.scm
;;*********************************************************************
;; This file provides the procedure testload.  testload is like
;; load, but it will display the results of each evaluation as it reads
;; the file, and it will catch errors and continue reading the file.

(provide 'testload)

(define top-level-environment (the-environment))

(define (error-string error-msg)
  (string-append
    (format #f "~s: " (car error-msg))
    (apply format #f (cdr error-msg))
    ))

(define testload
  (lambda (input-file-name output-file-name)
    (let ((in (open-input-file input-file-name))
          (out (open-output-file output-file-name))
          )
      (flush-output-port out)
      (format out "Evaluating file ~a~%Time start: ~a~%" input-file-name (system:time-string))
      (let loop ()
        (let ((expr (read in)))
          (flush-output-port out)
          (format out "---> ~a~%" expr)
          (flush-output-port out)
          (if (not (eof-object? expr))
              (let ((result
                      (call-with-current-continuation
                        (lambda (catch)
                          (fluid-let
                            ((error-handler
                               (lambda msg
                                 (format out "~a~a~%" "*** Error "
                                         (error-string msg))
                                 (catch #f)
                                 )))
                            (eval expr top-level-environment)
                            )))))
                (print result out)
                (flush-output-port out)
                (loop)
                ))))
      (format out "Time end: ~a~%" (system:time-string))
      (close-input-port in)
      (close-output-port out)
      )))

;;*********************************************************************
;; Viewmod.scm
;;*********************************************************************
;------------------------------------------------------------------
; Perform interactive modification of views.
; Button 1 performs spherical rotation about the target position
; Button 2 pans the view in X and Y
; Button 3 zooms the view
; (viewmod #t) turns on interaction. and (viewmod #f) turns off interaction.
;------------------------------------------------------------------
(provide 'viewmod)

(require 'math "math.scm")
(require 'old-rb "old-rb.scm")

(define zoom-step 0.1)
(define viewmod-state #f)

(define viewmod
  (lambda (onoff)
    (let* ((orig-view #f)
           (orig-y 0)
           (orig-width 0)
           (orig-height 0)
           (button 0)
           (radius 1)
           (sil_status #f)
           (prev-event #f))
      (if onoff
          ;; TRUE: Define mouse hooks for tracking position
          (begin
            (set! viewmod-state #t)
            ;; When button pressed, save original view info & start tracking
            (set! mouse-down-hook
                  (lambda (pe)
                    (if (= button 0)
                        (begin
                          (set! orig-view (event:view pe))
                          (set! orig-width (view:width orig-view))
                          (set! orig-height (view:height orig-view))
                          (set! radius (/ (min orig-width orig-height) 6.4))
                          (set! sil_status (dl:dynamic-silhouette-display #f))
                          (rb:scheme #t)
                          )
                        (rb-update-hook pe)
                        )
                    (set! orig-y (event:y pe))
                    (set! prev-event pe)
                    (set! button (+ (if (event:left?   pe) 1 0)
                                    (if (event:middle? pe) 2 0)
                                    (if (event:right?  pe) 4 0)))
                    )
                  )
            ;; As mouse moves, update view and refresh
            (set! rb-update-hook
                  (lambda (pe)
                    (if (> button 0)
                        (let* ((vt (view:target orig-view))
                               (ve (view:eye orig-view))
                               (vn (gvector:from-to vt ve))
                               (p1 (pick:position prev-event vt vn))
                               (p2 (pick:position pe vt vn))
                               (v1 (gvector:from-to p1 p2)))
                          (cond
                            ((or (= button 1) (= button 6))
                             (let* ((p3 (position:project-to-line vt p1 v1))
                                    (d3 (min (position:distance vt p3) radius))
                                    (h (sqrt (- (* radius radius) (* d3 d3))))
                                    (v2 (gvector:scale (gvector:unitize vn) h))
                                    (p4 (position:offset p1 v2))
                                    (v4 (gvector:from-to vt p4))
                                 )
							   (define dist (max (position:distance vt p3) radius))
							   (if (< (gvector:length v1) 1) (begin
							   	(set! v1 (gvector:scale v1 100))
							   	(set! v4 (gvector:scale v4 100))
							   	(set! dist (* dist 100))
							   ))
							   (define axis (gvector:cross v1 v4))
							   (define angle (radians->degrees (/ (gvector:length v1) dist)))
                               ;(printf "angle=~a, v1=~a, v4=~a, vt=~a, axis=~a ~a" angle v1 v4 vt axis (transform:rotation vt axis angle))
                               ;(display "    ") (transform:print (transform:rotation vt axis angle))
                               (view:set-eye (position:transform ve (transform:rotation vt axis angle)) orig-view)
                               (view:set-up (gvector:transform (view:up orig-view) (transform:rotation (position 0 0 0) axis angle)) orig-view)
                               ))
                            ((or (= button 2) (= button 5))
                             (let ((trans (transform:translation
                                            (gvector:reverse v1))))
                               (view:set-target (position:transform vt trans) orig-view)
                               (view:set-eye (position:transform ve trans) orig-view)
                               ))
                            ((or (= button 4) (= button 3))
                             (if (view:perspective?)
                                 (let ((trans (transform:translation
                                                (gvector:scale vn (* zoom-step
                                                                     (- (event:y pe) (event:y prev-event)))))))
                                   (view:set-target (position:transform vt trans)
                                                    orig-view)
                                   (view:set-eye (position:transform ve trans) orig-view)
                                   )
                                 (let* ((delta (* zoom-step (- (event:y pe) orig-y)))
                                        (factor (if (positive? delta)
                                                    (+ 1 delta)
                                                    (/ 1 (- 1 delta)))))
                                   (view:set-size (* orig-width factor)
                                                  (* orig-height factor)
                                                  orig-view)
                                   )
                                 ))
                            )
                          (view:refresh orig-view)
                          (view:draw-point (view:target orig-view) orig-view)
                          (set! prev-event pe)
                          )
                        )
                    )
                  )
            ;; When button released, stop tracking
            (set! mouse-up-hook
                  (lambda (pe)
                    (if (event:shift? pe)
                     (begin
                       (define old_raysize (option:set "raysize" (* 10 (car (env:tolerance)))))
                       (let* ( (pr (event:ray pe))
                                (ent #f)
                                (pos #f)
                                (hit_list (api_ray_test pr (car (env:tolerance))))
                            )
                            (if (< 0 (length hit_list))
                                (let ()
                                    (set! pos (list-ref (list-ref hit_list 0) 2))
                                    (if (< (position:x pos) 1000000000) (view:set-target pos))
                                    (view:refresh)
                                )
                            )
                       )
                       (option:set "raysize" old_raysize)
                     )
                    )
                    (if (> button 0)
                        (let ((new-button (- button (expt 2 (- (event:button pe) 1)))))
                          (if (= new-button 0)
                              (begin
                                (rb:scheme #f)
                                (dl:dynamic-silhouette-display sil_status)
                                )
                              )
                          (rb-update-hook pe)
                          (set! orig-y (event:y pe))
                          (set! prev-event pe)
                          (set! button new-button)
                          )
                        )
                    )
                  )
            )
          ;; FALSE: Turn off tracking capability
          (begin
            (set! viewmod-state #f)
            (set! mouse-down-hook (lambda (pe) (set! prev-event pe)) )
            (set! mouse-up-hook   (lambda (pe) (set! prev-event pe)) )
            (set! rb-update-hook  (lambda (pe) (set! prev-event pe)) )
            )
          )
      ;; Return the new setting
      onoff
      )
    )
  )

(provide 'viewmod?)
(define viewmod?
    (lambda ()
        viewmod-state
    )
)

(viewmod #t)

;;*********************************************************************
;; printf.scm
;;*********************************************************************
;----------------------------------------------------------------------
; Procedure for formated output.
;----------------------------------------------------------------------
(provide 'printf)
(define printf (lambda l (apply format (cons #t l)) (newline)))

;;*********************************************************************
;; Synread.scm
;;*********************************************************************
;----------------------------------------------------------------------
; Procedure for reading data file for syntx command.
;----------------------------------------------------------------------
;
; The Following files are loaded for the Syntax command
;
; Find the index data for a given ACIS Scheme extension command
;

(provide 'synread)

(define find-name (lambda (dataport command_name)
                    (define found 0)
                    (define out_list (list))
                    (let f ((x (read dataport)))
                      ; Search to the end of the file or found is equal to one.
                      (if (or (eof-object? x) (= found 1))
                          (begin
                            ; return a list of the found numbers.
                            out_list
                            )
                          (begin
                            ; Get the line number for this command
                            (define y (read dataport))
                            (if (string-ci=? command_name (symbol->string x))
                                (begin
                                  (define start 0)
                                  (set! start y)
                                  ; Get the next name
                                  (define next_name (read dataport))
                                  (define end 0)
                                  ; Get the next line number so we have the end of the command.
                                  (set! y (read dataport))
                                  (set! end y)
                                  ; Put these line numbers into a list so we can return them
                                  (set! out_list (list start))
                                  (set! out_list (append out_list (list end)))
                                  ; Set found to one so we stop the search
                                  (set! found 1)
                                  )
                                )
                            ; using tail recusion find the next command name.
                            (f (read dataport))
                            ))
                      )
                    ))

;
; Read a line from a file
;
(define (read-line . arg)
  (let* ((char (apply read-char arg)))
    (if (eof-object? char)
        char
        (do ((char char (apply read-char arg))
             (clist '() (cons char clist)))
            ((or (eof-object? char) (char=? #\newline char))
             (list->string (reverse clist)))))))
;
;Print out the syntax file from the star to end value
;
(define syntax-print (lambda (filename start_end)
                       (begin
                         ; Get the start and end line numbers
                         (define start (list-ref start_end 0))
                         (define end (list-ref start_end 1))
                         ; Open the Syntax data file.
                         (define dataport (open-input-file filename))
                         ; read to the start of the data
             ; use read-string not read-line, it's MUCH faster,
             ; conses much less too, and actually reads a whole line
             (do ((count 1 (+ count 1))) ((= count start))
               (read-string dataport))
                         ; Print the data out
                         (do ((count (- start 1) (+ count 1))) ((= count (- end 2)))
                             (define x (read-line dataport))
                             (if (not (eof-object? x))
                                 (begin
                                   (printf x)
                                   )
                                 )
                             )
                         
                         ; close data file
                         (close-input-port dataport)
                         )
                       ))
;
; Seach for a file with the load path
; return the file with the path if it is found
; Here is a usefull command
;
(define find-file
  (lambda ( in_file )
    (define name (string))
    (define found 0 )
    (begin
      ; Get the start and end line numbers
      (define path_list load-path)
      ; read to the start of the data
      (do ((count 0 (+ count 1))) ((or (= count (length path_list)) (= found 1)))
          (begin
            (define path (list-ref path_list count))
            (define temp (string-append path "/") )
            (define try_name (string-append temp in_file))
            (if (file-exists? try_name )
                (begin
                  (set! name try_name)
                  (set! found 1)
                  )
                )
            )
          )
      )
    name
    )
  )

;;*********************************************************************
;; Syntax.scm  -  requires a dat file
;;*********************************************************************
;----------------------------------------------------------------------
; Find the syntax of an ACIS Scheme extension command
; (syntax 'solid:skin-faces )
;
;returns
;"   (SOLID:SKIN-FACES face0 face1 [arc_length]"
;"       [minimize_twist] [align_directions] [simplify])"
;""
;"Arg Types:"
;"   arc_length                     boolean"
;"   align_directions               boolean"
;"   face0                             face"
;"   face1                             face"
;"   minimize_twist                 boolean"
;"   simplify                       boolean"
;""
;------------------------------------------------------------------
; The Syntax command needs two files syntax.txt and syntax_index.txt
; These file need to be updated for every release
; They are generated by the following ksh commands
;
; find pool4.0 -name "[a-z]*_scm.cxx" > scm_cxx.lst
; for file in `cat scm_cxx.lst`
; do
; syntax $file
; done
;
; syntax_index
;
; The following is the syntax command.
; cat $1 | awk '/\/\/[ ]*Syntax:[ ]*/, /\/\/[ ]*Returns:[ ]*/' | grep -v Returns |
;    sed '1,$s/\/\/ //g' | sed '1,$s/       /    /g' >> syntax.dat
;
; The following is the syntax_index command.
; cat syntax.dat | awk 'BEGIN {count=0;} {count++;} /[ ]*\([A-Z]*/ {print $1 " " count}' |
;   sed '1,$s/(//' | sed '1,$s/)//' > syntax_index.dat ; echo "end-of-file `cat syntax.dat |
;   wc -l`" >> syntax_index.dat

(provide 'syntax)

; Scheme Syntax procedure
(define syntax (lambda (command_name )
                 (begin
                   (if (symbol? command_name)
                       (set! command_name (symbol->string command_name))
                       (if (not (string? command_name))
                           (error 'syntax "string or symbol expected")))
                   (define out_list (list))
                   (define start_end (list))
                   ; Open index file
                   (define syntax_index_file (find-file "syntax_index.dat"))
                   (if (not (string=? syntax_index_file "") )
                       (begin
                         (define dataport (open-input-file syntax_index_file))
                         ; Find the index of the comand
                         (define start_end (find-name dataport command_name))
                         ; close data file
                         (close-input-port dataport )
                         ;Print the syntax data for the given command
                         (if (not (null? start_end) )
                             (begin
                               (define syntax_file (find-file "syntax.dat"))
                               (if (not (string=? syntax_file "") )
                                   (syntax-print syntax_file start_end)
                                   (error 'syntax "syntax.dat file not found. Try adding the Scheme examples directory to LOAD-PATH")
                                   )
                               )
                             (error 'syntax "Command not found.")
                             )
                         )
                       (error 'syntax "syntax_index.dat file not found. Try adding the Scheme examples directory to LOAD-PATH")
                       )
                   )
                 ))

;;*********************************************************************
;; Help
;;*********************************************************************
; Find scheme procedures whose name includes a given string.
; example,
;----------------------------------------------------------------------
;         ((if (substring? what (symbol->string (car l)))
;            (got-one (car l))
;(display "yes A\n")

(provide 'help)

(define strsubtract (lambda (str1 str2)
                      (define strlen1 (string-length str1))
                      (define strlen2 (string-length str2))
                      (define str3 "")
                      (if (and (substring? str1 str2)(and (> strlen2 strlen1) (> strlen1 0)))
                          (do ((i strlen2 (- i 1)))((or (<= i 0)(> (string-length str3) 0)))
                              (if (not(substring? str1 (substring str2 0 i)))
                                  (if (< i (- strlen2 1))
                                      (set! str3 (substring str2 (+ i 1) strlen2))(set! str3 "")
                                      )
                                  )
                              )
                          )
                      str3
                      )
  )
(define headsubstring? (lambda (str2 str1)
                         (if (and (> (string-length str2) 0)(>= (string-length str1) (string-length str2)))
                             (string=? str2 (substring str1 0 (string-length str2)))
                             #f)
                         )
  )
(define tailsubstring? (lambda (str2 str1)
                         (if (and (> (string-length str2) 0)(>= (string-length str1) (string-length str2)))
                             (string=? str2 (substring str1 (-(string-length str1)(string-length str2)) (string-length str1))) #f)
                         )
  )
;(display "yes A1\n")
(define allsubstr? (lambda (str strvec nstring)
                     (define tmpstr)
                     (define ret #t)
                     (if (<= nstring (vector-length strvec))
                         (begin(define tmpsymstr str)
                               (do ((i 0 (+ 1 i)))((>= i nstring))
                                   (begin(set! tmpstr (vector-ref strvec i))
                                         (if ( > (string-length tmpstr) 0)
                                             (if (not (substring? tmpstr  tmpsymstr))
                                                 (set! ret #f)(set! tmpsymstr (strsubtract  tmpstr tmpsymstr))
                                                 ))
                                         
                                         )
                                   ))(set! ret #f))
                     ret
                     )
  )
(define help)

(let ((found))
  (define (got-one sym)
    (if (bound? sym)
        (begin
          (set! found #t)
          (print sym))))
  
  (set! help (lambda (what)
               (if (symbol? what)
                   (set! what (symbol->string what))
                   (if (not (string? what))
                       (error 'help "string or symbol expected")))
               (define star #\*)
               (define fstar)
               (define mstar)
               (define lstar)
               (define fmlstar)
               (define fmstar)
               (define flstar)
               (define ofstar)
               (define mlstar)
               (define omstar)
               (define olstar)
               (define nostar)
               (if (char=? star  (string-ref what 0)) (set! fstar #t) (set! fstar #f))
               (define last (- (string-length what) 1))
               (if (char=? star  (string-ref what last)) (set! lstar #t) (set! lstar #f))
               (define whatcut (substring what 1  (string-length what)))
               (define whatmid  (substring whatcut 0  (- (string-length whatcut) 1)))
               (if (substring? "*" whatmid)(set! mstar #t)(set! mstar #f))
               (if (and (and fstar mstar) lstar) (set! fmlstar #t)(set! fmlstar #f))
               (if (and (and fstar mstar) (not lstar)) (set! fmstar #t)(set! fmstar #f))
               (if (and (and fstar (not mstar)) lstar) (set! flstar #t)(set! flstar #f))
               (if (and (and fstar (not mstar)) (not lstar)) (set! ofstar #t)(set! ofstar #f))
               (if (and (and (not fstar) mstar) lstar) (set! mlstar #t)(set! mlstar #f))
               (if (and (and (not fstar) mstar) (not lstar)) (set! omstar #t)(set! omstar #f))
               (if (and (and (not fstar) (not mstar)) lstar) (set! olstar #t)(set! olstar #f))
               (if (and (and (not fstar) (not mstar)) (not lstar)) (set! nostar #t)(set! nostar #f))
               (if fstar (set! what whatcut))
               (if lstar (set! what (substring what 0 (- (string-length what) 1))))
               (define bcharpos 0)
               (define n 0)
               (define nstring 0)
               (define symstr)
               (define tmpstr)
               (define symstr)
               (define symlen)
               (define whatlen (string-length what))
               (define strvec (make-vector 10))
               ;(display "yes B\n")
               (if mstar (begin(define l (string->list what))
                               (do ((strtail l  (cdr strtail))) ((null? strtail))
                                   (begin(if (or (char=? star (car strtail))(null? (cdr strtail)))
                                             (begin(if (not (char=? star (car strtail))) (set! n (+ 1 n)))
                                                   (if (> n bcharpos)(begin(vector-set! strvec nstring (substring what bcharpos n))
                                                                           (set! nstring (+ 1 nstring))))
                                                   (set! bcharpos  (+ 1 n))))
                                         (set! n (+ 1 n))))
                               ))
               ;(display "\n")
               ;(display (vector-ref strvec 0) )
               ;(display "\n")
               ;(display (vector-ref strvec 1) )
               ;(display "\n")
               ;(display "yes C\n")
               ;(display what)
               ;(display "\n")
               (set! found #f)
               (do ((tail (oblist) (cdr tail))) ((null? tail))
                   (do ((l (car tail) (cdr l))) ((null? l))
                       (begin(set! symstr (symbol->string (car l)))
                             (set! symlen (string-length symstr))
                             (set! tmpstr (string-copy symstr))
                             (if nostar
                                 (if (string=? what symstr)
                                     (got-one (car l))
                                     )
                                 (if ofstar
                                     (if (tailsubstring? what symstr)
                                         (got-one (car l)))
                                     (if (and olstar (> symlen whatlen))
                                         (if (headsubstring? what symstr)
                                             (got-one (car l)))
                                         (if omstar(if (and (and (headsubstring? (vector-ref strvec 0)symstr)(tailsubstring? (vector-ref strvec (- nstring 1))symstr)) (allsubstr? symstr strvec nstring))(got-one (car l)))
                                             (if fmlstar (if (allsubstr? symstr strvec nstring)(got-one (car l)))
                                                 (if flstar (if (substring? what symstr)(got-one (car l)))
                                                     (if fmstar (if (and (tailsubstring? (vector-ref strvec (- nstring 1)) symstr)(allsubstr? symstr strvec nstring))(got-one (car l)))
                                                         (if mlstar (if (and (headsubstring? (vector-ref strvec 0) symstr)(allsubstr? symstr strvec nstring))(got-one (car l))) )
                                                         )
                                                     )
                                                 )
                                             )
                                         )
                                     )
                                 )
                             )
                       )
                   )
               ;(display "yes D\n")
               (if (not found)
                   (format #t "~a: nothing appropriate~%" what))
               #v)))

(define percent-err (lambda (trueValue calcValue)
    (define returnValue 0.0)
    (if (and (= 0.0 trueValue) (= 0.0 calcValue))
        (set! returnValue 0.0)
        ;else
        (begin
            (if (= 0.0 trueValue)
                (set! returnValue 100.0)
                ;else
                (set! returnValue (* 100 (/ (abs (- trueValue calcValue)) trueValue)))
            )
        )
    )
    returnValue
))

; Find the surface area of an entity or entity-list.
(define entity-area (lambda (ent)
    (define sumArea 0)
    (if (or (body? ent) (or (lump? ent) (or (shell? ent) (face? ent))))
        (set! sumArea (car (solid:area ent .001)))
        ;else
        (if (entity-list? ent)
            (for-each (lambda (ent) (set! sumArea (+ sumArea (entity-area ent)))) ent)
        )
    )
    sumArea
))

; Verify the closeness of the surface area of an entity to the total area of facets of the entity.
; Displays various information.
; Returns the percent error.
(define verify-facet-area (lambda (elist)
    (define returnValue 0)
    (display "Verifying facet area for ") (display elist) (newline)
    (define facetArea (entity:facet-area elist))
    (display "facetArea   = ") (display facetArea) (newline)
    (define surfaceArea (entity-area elist))
    (display "surfaceArea = ") (display surfaceArea) (newline)
    (define perc (percent-err surfaceArea facetArea))
    (set! perc (/ (round (* perc 100)) 100)) ; set precision to 2 decimal places
    (display "percentErr  = ") (display perc) (display "%") (newline)
    (newline)
    (set! returnValue perc)
    returnValue
))

(define view:frustum (lambda()
    (if (and (equal? #f (env:active-view)) (not (null? env:views))) (env:set-active-view (car (env:views))))
    (define x (view:frustum-corners))
    (define v1 (gvector:from-to (view:target) (view:eye)))
    (define nul (position:project-to-plane (view:target) (view:eye) v1))  ;; near upper left of camera
    (define nur nul)  ;; near upper right of camera
    (define nll nul)  ;; near lower left of camera
    (define nlr nul)  ;; near lower right of camera
    (if (not (view:perspective?)) (begin
       (set! nul (position:project-to-plane (car x) (view:eye) v1))
       (set! nur (position:project-to-plane (cadr x) (view:eye) v1))
       (set! nll (position:project-to-plane (cadddr x) (view:eye) v1))
       (set! nlr (position:project-to-plane (caddr x) (view:eye) v1))
    ) )
    (define ful (position    ;; far upper left
        (- (position:x (car x)) (gvector:x v1))  
        (- (position:y (car x)) (gvector:y v1)) 
        (- (position:z (car x)) (gvector:z v1)) ) )
    (define fur (position    ;; far upper right
        (- (position:x (cadr x)) (gvector:x v1))  
        (- (position:y (cadr x)) (gvector:y v1)) 
        (- (position:z (cadr x)) (gvector:z v1)) ) )
    (define fll (position    ;; far lower left
        (- (position:x (cadddr x)) (gvector:x v1))  
        (- (position:y (cadddr x)) (gvector:y v1)) 
        (- (position:z (cadddr x)) (gvector:z v1)) ) )
    (define flr (position    ;; far lower right 
        (- (position:x (caddr x)) (gvector:x v1))  
        (- (position:y (caddr x)) (gvector:y v1)) 
        (- (position:z (caddr x)) (gvector:z v1)) ) )
    (view:gl)
    (define ro1 (ro:line nul ful))
    (define ro2 (ro:line nur fur))
    (define ro3 (ro:line nll fll))
    (define ro4 (ro:line nlr flr))
    (define box1 (ro:polyline (list nul nur nll nlr nul) ) )
    (define box2 (ro:polyline (list ful fur fll flr ful) ) )
    (ro:set-color box1 RED)
    (iso)
    (zoom-all)
    (list box1 box2 ro1 ro2 ro3 ro4)
) )

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; The following macros were added by Guy, Nov 10, 2014.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (view:ray . args)   ; Uses (part:entities) if first arg is not an entity or a list of entities
    (define pos  '())
    (define gvec '())
    (define ret_value '())
    (define ray_render_objects '())
    (define both_dirs #f)
    (define rad -1.0)
    (define error #f)
    (define verbose_level 'q)
    (do ((a args (cdr a))) ((null? a))
        (define arg (car a))
        (if (symbol? arg) (set! arg (symbol->string arg))) ; In order to process strings and quote expressions the same.
        (cond
            ((ray? arg)   (begin (set! pos (ray:position arg)) (set! gvec (ray:gvector arg)) ) )
            ((boolean? arg)   (set! both_dirs arg) )
            ((real? arg)   (set! rad arg) )
            ((string? arg)
                (cond
                    ((equal? arg "q") (set! verbose_level arg) )
                    ((equal? arg "Q") (set! verbose_level arg) )
                    ((equal? arg "v") (set! verbose_level arg) )
                    ((equal? arg "V") (set! verbose_level arg) )
                    ((equal? arg 'b) (set! both_dirs #t) )
                    ((equal? arg 'o) (set! both_dirs #f) )
                    (else (set! error #t))
                )
            )
            (else (set! error #t))
        )
    )
    (if (or error (eq? pos '()) (eq? gvec '()) )
        (begin
            (display "Pick a spot for the ray...")
            (rbd:push rb-ray)
            (define pick_ray (read-ray))
            (rbd:pop)
            (newline)
            (set! pos (ray:position pick_ray))
            (set! gvec (ray:gvector pick_ray))
            (set! both_dirs #t)
            (if (< rad 0.0) (set! rad (option:get 'raysize)))
        )
    ) ; end if
    (if (or error (eq? pos '()) (eq? gvec '()) )
        (begin
            (display "   Syntax: (view:ray [ray] [radius] ['b] ['o] ['q] ['v] ['V]).\n")
            (display "   where [ray] can be: (ray (position x y z) (gvector t u v))\n")
            (display "   Returns a list: ray, ray end point, ray radius, and a list of arrow rendering objects.\n")
            (display "   Bi-directional arrow: 'b == bidirectional, 'o == one direction.\n")
            (display "   Verbosity level: 'Q == very Quiet (no return value), 'q == less quiet, 'v == some verbosity (default), 'V == more Verbosity.\n")
            (display "   Args can be in any order.\n")
            (display "   If no args, just click on view, and an appropriate ray will be made.\n")
        ) ; else
        (begin
            (if (< rad 0.0) (set! rad 0.0))
            (define bbox (entity:box (part:entities)))
            (define midpt (position (/ (+ (position:x (car bbox) ) (position:x (cdr bbox))) 2)
                                    (/ (+ (position:y (car bbox) ) (position:y (cdr bbox))) 2)
                                    (/ (+ (position:z (car bbox) ) (position:z (cdr bbox))) 2)
            ) )
            (define cent_pos (position:project-to-plane pos midpt gvec) )
            (define len (entity:diag (part:entities) #f 'q))
            (set! gvec (gvector:unitize gvec) )
            (define end_vec (gvector:scale gvec (* .5 len))) 
            ; Do we go in both direction, or just in the positive direction?
            (if both_dirs
                (define start_pos (position (-(position:x cent_pos)(gvector:x end_vec))
                                            (-(position:y cent_pos)(gvector:y end_vec))
                                            (-(position:z cent_pos)(gvector:z end_vec))))
              ;else
                (define start_pos pos)
            )
            (define end_pos (position   (+(position:x cent_pos)(gvector:x end_vec))
                                        (+(position:y cent_pos)(gvector:y end_vec))
                                        (+(position:z cent_pos)(gvector:z end_vec))))
            (if (equal? "v" verbose_level)
                (printf "   Ray starts at ~a\n   Ray ends   at ~a\n   Ray gvector:  ~a, Radius: ~a." start_pos end_pos gvec rad)
            )
            (if (not (equal? '() env:views)) (if (> rad 0.0)
              (set! ray_render_objects (list (ro:arrow start_pos end_pos)
                                (ro:cylinder start_pos end_pos rad (env:default-color ) "none")))
              (set! ray_render_objects (list (ro:arrow start_pos end_pos) ))
            ) )
            (view:refresh)
            (if (equal? "V" verbose_level)
                (printf "    (ray:queue ~a ~a ~a   ~a ~a ~a   ~a)" (position:x start_pos) (position:y start_pos) (position:z start_pos) 
                    (gvector:x gvec) (gvector:y gvec) (gvector:z gvec) rad)
            )
            (set! ret_value (list (ray start_pos end_vec) end_pos rad ray_render_objects) )
        )
    ) ; end else
    (if (equal? "Q" verbose_level)
        (set! ret_value '())
    )
    ret_value
)

(define round_number (lambda ( number pow ) (* (round (/ number (expt 10 pow)) ) (expt 10 pow)) ) ) 

(define (view:get)
  (define ey (view:eye))
  (define tg (view:target))
  (define up (view:up))
  (define w  (view:width))
  (define vpw (caddr  (view:viewport)))
  (define vph (cadddr (view:viewport)))

  (printf ";(view:gl 0 0 ~a  ~a)   (zoom-all)" vpw vph )
  (printf "(view:set-eye (position  ~a  ~a  ~a))"    (round_number (position:x ey) -6) (round_number (position:y ey) -6) (round_number (position:z ey) -6) )
  (printf "(view:set-target (position  ~a  ~a  ~a))" (round_number (position:x tg) -6) (round_number (position:y tg) -6) (round_number (position:z tg) -6) )
  (printf "(view:set-up (gvector  ~a  ~a  ~a))"     (round_number (gvector:x up)   -6) (round_number (gvector:y up)  -6) (round_number (gvector:z up)  -6) )
  (printf "(view:set-size  ~a  ~a)" (round_number w -6) (round_number w -6))
  (printf "(view:refresh)")
  (newline)
)

(define view:print-setup (lambda()
    (view:set-bg-color WHITE)
    (entity:set-color (entity:edges (part:entities)) BLACK)
    (entity:set-color (entity:vertices (part:entities)) BLACK)
))

(define (entity:diag . args) (begin
    (define ents '())
    (define verbose #t)
    (do ((a args (cdr a))) ((null? a))
        (if (or (entity? (car a)) (entity-list? (car a)) )   (set! ents (car a)) )
        (define arg (car a))
        (if (symbol? arg) (set! arg (symbol->string arg))) ; In order to process strings and quote expressions easier
        (if (and (string? arg) (equal? arg "q") )   (set! verbose #f) )
        (if (and (string? arg) (equal? arg "v") )   (set! verbose #t) )
    )
    (if (null? ents)  (set! ents (part:entities)) )
    (define box (entity:box ents))
    (define p0 (car box))
    (define p1 (cdr box))
    (define dist (position:distance p0 p1))
    (if verbose (begin
        (printf "LowLeft Corner: ~a\nUpRight Corner: ~a" (car box) (cdr box))
        (printf "x_dist= ~a, y_dist= ~a, z_dist = ~a"
            (abs (- (position:x p0) (position:x p1)))       
            (abs (- (position:y p0) (position:y p1)))       
            (abs (- (position:z p0) (position:z p1)))
        )
        ;(printf "(diag/500 =~a)  (diag/1000 = ~a)" (/ dist 500) (/ dist 1000) )
    ) )
    dist
) )

(define (entity:remove-colors . args) (begin    ; Use (part:entities) if first arg is not an entity or a list of entities
    (define params '())
    (if (null? args)
      (begin
        (set! params (part:entities))
      ) ; else
      (begin
        (if (or (entity? (car args)) (entity-list? (car args)))
            (set! params args)
            (set! params (append params (list (part:entities)) args))
        )
      )
    )
    (if (not (list? params)) (set! params (list params)))
    (define (remcolor ent) (begin
        ;(display "  Attribs: ") (display (map entity:debug (entity:attribs ent)))
        ; Find it in the SAT file. It may have "-st-attrib" post-fixed to it. 
        (define att_list (entity:attribs ent))
        (entity:lose-attribs ent "rgb_color-st-attrib")
        (entity:lose-attribs ent "render-rbase-attrib")
    ) )
    (map remcolor params)
    (render:rebuild)
) )

(define entity:shiny (lambda( ents shininess )
    (if (list? ents)
        (map (lambda(ent) (entity:set-material-reflection ent .95 .95 shininess 15) ) (part:entities))
        (entity:set-material-reflection ents .95 .95 shininess 15)
    )
) )

(define entity:pick-uv (lambda ( )
    (define pent (pick-ents))
    (define ent1 (caar pent) )
    (define face1 (car (entity:faces ent1) ) )
    (define surf1 (surface:from-face face1))
    (define pos1 (caddar pent))
    (define result (surface:param surf1 pos1))
    result
))

(define entity:names (lambda (entity_name_ent)
    (letrec ((p_list (part:entities))
            (return_list '()))
        (let loop ((e_list (environment->list (the-environment))))
            (if (not (null? e_list)) ;; if list is not null
                (if (symbol? (car e_list)) ;; and first part is a symbol
                    (if (entity? (cdr e_list) ) ;; and second part is an entity
                        (if (equal? entity_name_ent (cdr e_list) ) (begin
                          (if (not (string=? (symbol->string (car e_list) ) "entity_name_ent") ) (begin
                            (set! return_list (cons (car e_list) return_list))
                            ;(format #t "  ~a      \t~a  \t~a~%" (car e_list)  (entity:debug (cdr e_list)) (cdr e_list))
                          ) )
                        ) )
                    )
                    (begin ;; if first part is not a symbol
                      (loop (car e_list)) ;; loop with first part
                      (loop (cdr e_list))
                    )
                )
            )
        )
        return_list
    )
) )

(define (pick-edge-names) (list-print (map (lambda(e) (entity:names e)) (pick-edges))) )  ; Pick Edges and Get Edge Names

(define entity:all_attribs (lambda (ents)
    (map (lambda (ent) (begin (printf " ~a " ent)  (map (lambda(att) (printf " ~a " (entity:debug att) ) ) (entity:attribs ent ) ) (newline) ) ) ents )
) )
; Example: (entity:all_attribs (entity:faces (part:entities)))

(define entity:attrib_details (lambda(ent) 
    (map (lambda(ent1) (display ent1) (newline) (entity:debug ent1 2) ) (entity:attribs ent))
) )

(define sort #f)
(define merge #f)
(let ()
  (define dosort
    (lambda (pred? ls n)
      (cond
        ((= n 1) (list (car ls)))
        ((= n 2) (let ((x (car ls)) (y (cadr ls)))
                   (if (pred? y x) (list y x) (list x y))))
        (else
         (let ((i (quotient n 2)))
           (domerge pred?
                    (dosort pred? ls i)
                    (dosort pred? (list-tail ls i) (- n i))))))))
  (define domerge
    (lambda (pred? l1 l2)
      (cond
        ((null? l1) l2)
        ((null? l2) l1)
        ((pred? (car l2) (car l1))
         (cons (car l2) (domerge pred? l1 (cdr l2))))
        (else (cons (car l1) (domerge pred? (cdr l1) l2))))))
  (set! sort
    (lambda (pred? l)
      (if (null? l) l (dosort pred? l (length l)))))
  (set! merge
    (lambda (pred? l1 l2)
      (domerge pred? l1 l2)))
)

(define symbols (lambda (what)
    (define funclist '())
    (let ((found))
        (define (got-one sym)
        (if (bound? sym)
            (begin
              (set! found #t)
              (set! funclist (append funclist (list (symbol->string sym)))))))
        (if (symbol? what)
            (set! what (symbol->string what))
            (if (not (string? what))
                (error 'symbols "string or symbol expected")))
        (set! found #f)
        (do ((tail (oblist) (cdr tail))) ((null? tail))
            (do ((l (car tail) (cdr l))) ((null? l))
                (if (substring? what (symbol->string (car l)))
                    (got-one (car l)))))
        (if (not found)
            (error 'symbols "nothing appropriate"))
    )
    (set! funclist (csort (lambda(x y) (string-ci<? x y)) funclist))
    (map (lambda (x) (printf "(~a )" x)) funclist )
    #v
) )

(define transform:max-diff (lambda (tr1 tr2) (begin
    ; Return a list of 4 values evaluating the difference between 2 transforms.
    ; 1) The absolute value of the difference in the scaling factor.
    ; 2) The length of the difference in the tanslation vectors.
    ; 3) The difference between the rotation angles in degrees.
    ; 4) The difference between the rotation axes in degrees.
    ; 5) The difference transform.
    ; Since we can apply a non-scaling transform to both transforms, let's use the inverse of one of them
    ; The inverse or tr1 applied to tr1 yeilds the identity matrix ( a transform yielding no change to the model).
    ; The inverse of tr1 applied to tr2 yeilds the difference between the 2 transforms.
    ; Todo: Check that the inverse is non-scaling.
    (define transf1 (transform:decompose tr1) )
    (define transf2 (transform:decompose tr2) )
    (define scale_diff (max
        (abs (- (list-ref (list-ref transf1 0) 1) (list-ref (list-ref transf2 0) 1) ) ) 
        (abs (- (list-ref (list-ref transf1 0) 2) (list-ref (list-ref transf2 0) 2) ) ) 
        (abs (- (list-ref (list-ref transf1 0) 3) (list-ref (list-ref transf2 0) 3) ) )
    ) )
    (define tr1_tr1inv (transform:decompose (transform:compose tr1 (transform:inverse tr1) ) ) )
    (define tr2_tr1inv (transform:decompose (transform:compose tr2 (transform:inverse tr1) ) ) )
    (define translate_diff (gvector:length (gvector (list-ref (list-ref tr2_tr1inv 1) 1) (list-ref (list-ref tr2_tr1inv 1) 2) (list-ref (list-ref tr2_tr1inv 1) 3) ) ) )
    (define rotate_angle_axis (gvector (list-ref (list-ref tr2_tr1inv 3) 1) (list-ref (list-ref tr2_tr1inv 3) 2) (list-ref (list-ref tr2_tr1inv 3) 3) ) )
    (define rotate_angle_diff (radians->degrees (list-ref (list-ref tr2_tr1inv 3) 4) ) )
    (list scale_diff translate_diff rotate_angle_diff rotate_angle_axis (transform:compose tr2 (transform:inverse tr1)) )
) ) )   

(define transform:report-diff (lambda (transf1 transf2 scale_tol translate_tol rotate_tol_degrees)
    ; Report the differences between 2 transforms, given tolerances
    ; This is easy in most cases, but extrememly difficult for some easy cases.
    ; A sphere has an infinity of transforms that yield results that look the same.
    ; A regulare solid (tetrhedron, cube, dodecahdron, ...) has as many identical looking results as (number_of_points * number_of_faces).
    ; So a cube can be tranformed so that any vertex transforms to any other vertex position, rotated 90 degrees, and still look like the original.
    ; A torus can be transformed about its axis, and also flipped 180 degrees, and still look like the original.
    ; But we really care about things that are not symetrical, or are rotated about one axis X degrees.
    (define maxs (transform:max-diff transf1 transf2) )
    (printf "Comparison of two transforms...")
    (if (< (list-ref maxs 0) scale_tol)
        (printf "   Scaling difference is okay: ~a < ~a" (list-ref maxs 0) scale_tol )
        (printf "   *** Error: Scaling difference is not okay: ~a !< ~a" (list-ref maxs 0) scale_tol )
    )
    (if (< (list-ref maxs 1) translate_tol )
        (printf "   Translation difference is okay: ~a < ~a" (list-ref maxs 1) translate_tol )
        (printf "   *** Error: Translation difference is not okay: ~a !< ~a" (list-ref maxs 1) translate_tol )
    )
    (if (< (list-ref maxs 2) rotate_tol_degrees )
        (printf "   Rotation difference is okay: ~a < ~a degrees." (list-ref maxs 2) rotate_tol_degrees )
        (printf "   *** Error: Rotation difference is not okay: ~a !< ~a degrees about ~a." (list-ref maxs 2) rotate_tol_degrees (list-ref maxs 3))
    )
) )

(define facet:delete (lambda (ent)
    (if (or (body? ent) (or (lump? ent) (or (shell? ent) (face? ent) ) ) )
        (entity:delete-facets ent #t)
        ;else
        (if (entity-list? ent)
            (for-each (lambda (ent) (facet:delete ent)) ent )
        )
    )
))

(define (refacet . args) (begin ; Use (part:entities) if first arg is not an entity or a list of entities
    (define params '())
    (if (null? args)
      (begin
		(define solids (part:entities (filter:or (filter:type "solid?") (filter:type "body?") (filter:type "face?") (filter:type "mixed-body?") ) ) )
        (set! params (list solids) )
      ) ; else
      (begin
		(define solids (part:entities (filter:or (filter:type "solid?") (filter:type "body?") (filter:type "face?") (filter:type "mixed-body?") ) ) )
        (if (or (entity? (car args)) (entity-list? (car args)))
		  (set! params args)
		;else
		  (set! params (append params (list solids) args) )
		)
	  )
	)
    (facet:delete (car params))
    (define t1 (timer:get-cpu-seconds))
    (define ret_val (apply entity:facet params))
    (define t2 (timer:get-cpu-seconds))
    (render:rebuild)
    (list ret_val (- t2 t1) )
) )

(define (facet:picker . args)
	(begin
		(define xxx (apply facet:pick args))
		(list-print xxx)
		xxx
	)
)

(define facet:embed_edge (lambda (b1 edge vec dist)
    ;  (embed_edge b1 (edge:linear (position 1 2 3) (position 4 5 6)) (gvector 0 0 -1) 9)
    (define b2 (wire-body (list edge) ) )
    (project:wire b2 b1 vec dist)
    (entity:delete b2)
) )

(define facet:embed_vertex (lambda ()
    (define x (pick-ents))
    (define vec_1 (gvector:scale (gvector:unitize (gvector:from-to (view:eye) (view:target) ) ) 0.01 ) )
    (define pos_1 (position:offset (list-ref (list-ref x 0) 2) vec_1))
    (define pos_2 (position:offset (list-ref (list-ref x 0) 2) (gvector:reverse vec_1)))
    (define wb_1 (wire-body:points (list pos_1 pos_2)))
    (define body_1 (entity:owner (caar x)))
    (solid:imprint body_1 wb_1)
    (entity:delete wb_1)
    (refacet)
    x
) )

(define (facet:watertight-errors ents )  ;;;;;;;; Not Water Tight Test
    (define bars '())
    (if (list? ents) (begin
        (map (lambda(ent) (begin
			(if (= 0 (entity:count-facets ent) )   (entity:facet ent)   )
			(define edges (facet:non-watertight ent) )
			;(if (= 0 (length edges) )
			;	(printf "Watertight:     ~a." ent)
			;	(printf "NOT WATERTIGHT: ~a at ~a edges." ent (length edges))
			;) 
			(if (null? bars)
				(set! bars edges)
			; else
				(set! bars (append bars edges ) )
			)
        ) ) ents ) ; end of map and lambda
    ) (begin ;else
        (set! bars (facet:non-watertight ents) )
    ) ) ; end if
    bars
)
; Example:  (define bars (facet:watertight-errors (part:entities)))   (list-print bars)  (test:equal 0 (length bars) "NOT WATERTIGHT")
; Example:  (define bars (facet:watertight-errors (part:entities (filter:type "solid?")) ) )   (if (not (boolean? bars)) (begin (list-print bars)  (test:equal 0 (length bars) "NOT WATERTIGHT")))
(define (facet:watertight?)
    (define bars (facet:watertight-errors (part:entities (filter:type "solid?")) ) )
	;(if (not (test:equal 0 (length bars) "NOT WATERTIGHT"))
	;	(printf "To display the 99th non-watertignt bar:  (roline bars 99)")
	;)
	bars
)
(define (roline pos_list pos_index) 
	(ro:line (car (list-ref pos_list pos_index)) (cadr (list-ref pos_list pos_index)))
	(view:refresh)
)

(define color_list (list    ;A list of fairly distinct colors, spread over the color spectrum.
    (color:rgb 0 0 0)   ;Black
    (color:rgb 1 1 1)   ;White
    (color:rgb (/ 173 255) (/  35 255) (/  35 255) )    ;Red
    (color:rgb (/  29 255) (/ 105 255) (/  20 255) )    ;Green
    (color:rgb (/  42 255) (/  75 255) (/ 215 255) )    ;Blue
    (color:rgb (/ 255 255) (/ 238 255) (/  51 255) )    ;Yellow
    (color:rgb (/ 129 255) (/  38 255) (/ 192 255) )    ;Purple
    (color:rgb (/  41 255) (/ 208 255) (/ 208 255) )    ;Cyan
    (color:rgb (/ 255 255) (/ 146 255) (/  51 255) )    ;Orange
    (color:rgb (/ 255 255) (/ 205 255) (/ 243 255) )    ;Pink
    (color:rgb (/ 157 255) (/ 175 255) (/ 255 255) )    ;Light. Blue
    (color:rgb (/ 233 255) (/ 222 255) (/ 187 255) )    ;Tan
    (color:rgb (/ 160 255) (/ 160 255) (/ 160 255) )    ;Light Gray
    (color:rgb (/ 129 255) (/ 197 255) (/ 122 255) )    ;Light Green
    (color:rgb (/ 129 255) (/  74 255) (/  25 255) )    ;Brown
    (color:rgb (/  87 255) (/  87 255) (/  87 255) )    ;Dark Gray
) )
(define (colorize . args) (begin
    (define ents '())
    (define ignore_black_and_white #t)
    (define color_count 0)
    (define syntax_error #f)
    (do ((a args (cdr a))) ((null? a))
        (define arg (car a))
        (if (symbol? arg) (set! arg (symbol->string arg))) ; In order to process strings and quote expressions the same.
        (cond
            ( (entity-list? arg) (set! ents arg) )
            ( (list? arg) (set! ents arg) )
            ( (integer? arg) (set! color_count arg) )
            ( (and (string? arg) (equal? arg "bw") )   (set! ignore_black_and_white #f) )
            (else (set! syntax_error #t))
        )
    )
    (if syntax_error
        (begin
            (display "Syntax:  (colorize [list] [2-16] ['bw])\n")
            (display "(colorize) If no list specified, use (entity:faces (part:entities))\n")
            (display "(colorize my_list_of_entities)\n")
            (display "(colorize 12) Cycle thru only 12 colors. Number can be between 2 and 16 colors (including black and white)\n")
            (display "(colorize 'bw) Include black and white. By default they are not included, assuming the background is either black or white.\n")
            (display "  The last few colors may not be distinct enough.\n")
            (display "  A dark shade of orange can look brown, A dark shade of light green looks green, and so on.\n")
            (display "  So you may want only the first 8, 10, or 12 colors.\n")
        ) ; else
        (begin
            (if (null? ents) (set! ents (entity:faces (part:entities) ) ) )
            (if (or (< color_count 1) (> color_count (length color_list)))
                (set! color_count (- (length color_list) (if ignore_black_and_white 2 0 ) ) ) ; subtract black and white from list
            )
            (define skip 0)
            (if ignore_black_and_white (begin
                (set! skip 2) )
                (set! color_count (- color_count 2) )
            )
            (set! color_count (+ color_count 1))
            (if (not (= 0 (length ents))) (begin
                (do ((i 0 (+ i 1))) ((>= i (length ents))) (begin 
                    (define modx (+ skip (modulo i (- color_count skip -1) ) ) )
                    ;(printf "~a" modx)
                    (entity:set-color (list-ref ents i) (list-ref color_list modx))
                ) )
            ) )
        )
    )
) )
;;+---------{ Sublist scheme function created by tme5 dated 25th May, 2017.}----------------------+
(define (sublist . args)
    (define (eval_input main_list input)
    (define flag #t)
    (define msg "*** Proper arguments. Proceeding with sublist function ***")
    (define option)
        (if (not (and (list? main_list)(> (length main_list) 1)))
            (begin
                (set! flag #f)
                (set! msg "main_list must be list of more than 2 elements")
            )
            (begin
                (if (list? input)
                    (begin 
                        (set! option 'discrete_indices)
                        (define len (length main_list))
                        (do ((i 0 (+ i 1)))((= i (- (length input) 1)))
                            (define ref (list-ref input i))
                            (if (not (integer? ref))
                                (begin
                                    (set! flag #f)
                                    (set! msg "Input index must be list of integers")
                                )
                            )
                            (> ref len)
                            (if (or (< ref 0)(> ref len))
                                (begin
                                    (set! flag #f)
                                    (set! msg "Input index must be >= 0 and < length of main_list")
                                )
                            )
                        )
                    )
                    (begin
                        (set! option 'cluster_mode)
                        (define start (car input))
                        (define end (cdr input))
                        (if (not (and (integer? start)(integer? end)))
                                (begin
                                    (set! flag #f)
                                    (set! msg "Input index must be list of integers")
                                )
                        )
                        (if (or (< start 0)(> end (length main_list)))
                                (begin
                                    (set! flag #f)
                                    (set! msg "Start index must be >= 0 and end index must be < length of main_list")
                                )
                        )
                    )
                )
            )
        )
    (list flag option msg)  
    )
    (define msg (format #f "Wrong input.\nSyntax :- (sublist main_list input) \nUsage :- main_list - list of integers, characters, string, etc \n input - pair of start and end reference or list of indices \nExample 1. (sublist (list 1 2 3 4 5 6 7) (cons 1 4)) ; returns (2 3 4 5)\n2. (sublist (list 1 2 3 4 5 6 7) (list 3 4 5)) ; returns (4 5 6)"))
    (define subl (list))
    (if (and (> (length args) 1)(< (length args) 3))
        (begin
            (define main_list (list-ref args 0))
            (define input (list-ref args 1))
            (define results (eval_input main_list input))
            (define flag (list-ref results 0))
            (define msg (list-ref results 2))
            (if flag
                (begin
                    ;(print msg)
                    (define option (list-ref results 1))
                    (case option
                        ((cluster_mode) (begin
                                        (define start (car input))
                                        (define end (cdr input))
                                        (do ((i start (+ i 1)))((= i (+ end 1)))
                                            (set! subl (append subl (list (list-ref main_list i))))
                                        )
                                    )
                        )
                        ((discrete_indices) (begin
                                            (do ((i 0 (+ i 1)))((= i (length input)))
                                                (define ref (list-ref input i))
                                                (set! subl (append subl (list (list-ref main_list ref))))
                                            )
                                        )
                        )
                    )
                )
                (test:equal #t #f msg)
            )
        )
        (test:equal #t #f msg)
    )
subl
)
;Example 1 :- (sublist (list 1 2 3 4 5 6 7) (cons 1 6)) ; returns (2 3 4 5 6 7)
;Example 2 :- (sublist (list 1 2 3 4 5 6 7) (list 3 1 5)) ; returns (4 2 6)


;;--------------------------------------------------- (nmap) ol7 :- 01-Jun-2017 --------------------------------------------------------;;

(define (=? args num) (define res (equal? (length args) num)) res)

(define (any_arg_list? args)
    
    (define flag #f)
    (do ((i 0 (+ i 1)))
        ((= i (length args)))
        
        (define this_arg (list-ref args i))
        (if (pair? this_arg)
            (set! flag #t)
        )
    )
    flag
)

(define (nmap func array . varargs)
    
    (if (not (or (or (or (or (or (string? func) (char? func)) (boolean? func)) (number? func)) (symbol? func)) (pair? func)))               
        (begin
        
            (if (list? array)
                (begin
                    
                    (if (not (any_arg_list? varargs))
                        (begin
                            
                            ; list of lists
                            (define list_lists (list (list)))
                            
                            ; create inner lists equal to the number arguments
                            (if (> (length varargs) 1)
                                (do ((i 0 (+ i 1)))
                                    ((= i (- (length varargs) 1)))
                                    (set-cdr! list_lists (append list_lists (list-ref list_lists i)))
                                )
                            )
                            
                            ; populate the inner lists with respective variable arguments
                            (do ((i 0 (+ i 1)))
                                ((= i (length varargs)))
                                (define inner (list-ref list_lists i))
                                (do ((j 0 (+ j 1)))
                                    ((= j (length array)))          
                                    (set! inner (append inner (list (list-ref varargs i))))
                                )
                                (set-car! (list-tail list_lists i) inner)
                            )
                            
                            ; no generalized way known to have map applied on lists of lists
                            ; (my_map func array . list_lists)
                            (cond
                                    ((=? varargs 0) (map func array))
                                    ((=? varargs 1) (map func array (car list_lists)))
                                    ((=? varargs 2) (map func array (car list_lists) (cadr list_lists)))
                                    ((=? varargs 3) (map func array (car list_lists) (cadr list_lists) (caddr list_lists)))
                                    ((=? varargs 4) (map func array (car list_lists) (cadr list_lists) (caddr list_lists) (cadddr list_lists)))
                                    ((=? varargs 5) (map func array (car list_lists) (cadr list_lists) (caddr list_lists) (cadddr list_lists) (car (cddddr list_lists))))
                            )
                            
                        )
                        
                        (begin
                            (test:equal #t #f "variable arguments cannot be a list/pair")
                        )
                    )
                
                )
            
                (begin
                    (test:equal #t #f "1st argument to scheme-extension is not a list")
                )
            )
            
        )
        
        (begin 
            (test:equal #t #f "inappropriate scheme-extension provided")
        )
    )
    
)

; e.g. (nmap entity:set-color (entity:faces ent) BLUE)
; e.g. (nmap edge:project-to-plane (entity:edges (car (part:entities))) (position -20 5 15) (gvector -1 -1 1))

;;-------------------------------------------------------------------------------------------------------------------------------------;;

(define (pick_checker entity_picked desired_id)
    (if (not (entity? entity_picked))
      (display "*** Error: No entity picked\n")
      (begin ;else
        (define ent_id (if entity (entity:get-id entity_picked) -9999999999)) ; If no entity is picked, Scheme will halt and catch fire.
        (newline)
        (printf "Test if desired entity==~a(ID=~a) equals picked entity==~a(ID=~a)" (history:get-entity-from-id desired_id) desired_id entity_picked ent_id)
        (display (if (equal? desired_id ent_id)
            "!!! Success!\n" 
            ; else
            "*** Error: Wrong entity is picked\n"
        ) )
      )
    )
)

(define (entity:tag-sync)
    (define p1 (part:entities))
    (entity:faces p1)
    (entity:edges p1)
    (entity:vertices p1)
    (entity:coedges p1)
    (if (body? (entity:owner (car (entity:faces p1))))
        (entity:get-id (car (entity:lumps (car (entity:faces p1))))) ; the 1st lump of (entity X) will have tag_no == 0
    )
    (map entity:get-id p1)
    (map entity:get-id (entity:faces p1))
    (map entity:get-id (entity:edges p1))
    (map entity:get-id (entity:vertices p1))
    (map entity:get-id (entity:coedges p1))
)

(define (ray_queue posx pos posz vecx vecy vecz radius)
    (define ray_pos (position posx pos posz))
    (define ray_vec (gvector vecx vecy vecz))
    (ray:queue (position:x ray_pos) (position:y ray_pos) (position:z ray_pos)
        (gvector:x ray_vec) (gvector:y ray_vec) (gvector:z ray_vec) radius)
    (ray ray_pos ray_vec)
)


;;--------------------------------------------------- (flatlist) ol7 :- 08-Jan-2018 --------------------------------------------------------;;

(define sublist_pair (cons (list) #t))

(define recurse
    (lambda (sub_list first)
        (if first
            (begin  
                (set-car! sublist_pair (list))
                (set-cdr! sublist_pair #t)
            )
        )
        (if (list? sub_list)
            (begin
                (define len_sublist (length sub_list))              
                (if (>= len_sublist 1)
                    (begin
                        (set! first #f)
                        (set! sublist_pair (recurse (car sub_list) first))
                        (set! sublist_pair (recurse (cdr sub_list) first))
                    )
                )
            )
            
            (begin
                (if (not (null? sub_list))
                    (begin
                        (set-cdr! sublist_pair #f)
                        (define temp_list (car sublist_pair))
                        (set! temp_list (append temp_list (list sub_list)))
                        (set-car! sublist_pair temp_list)
                    )
                )
            )
        )
    
    sublist_pair
    )
)

(define flatlist
    (lambda (biglist)
        (if (list? biglist)
            (begin
                (define empty_biglist_flag #t)
                (define flattened_list (list))
                
                (define len_biglist (length biglist))
                
                (do ((i 0 (+ i 1)))
                    ((= i len_biglist))
                    
                    (define elem (list-ref biglist i))
                    (if (list? elem)
                        (begin
                            (define len_elem (length elem))
                            (if (>= len_elem 1)
                                (begin                                  
                                    (define sublist_pair (recurse elem #t))
                                    (if (not (cdr sublist_pair))
                                        (begin
                                            (set! empty_biglist_flag #f)                                            
                                            (set! flattened_list (append flattened_list (car sublist_pair)))
                                        )
                                    )
                                )
                            )
                        )
                        
                        (begin
                            (if (not (null? biglist))
                                (begin
                                    (set! empty_biglist_flag #f)
                                    (set! flattened_list (append flattened_list (list elem)))
                                )
                            )
                        )
                    )
                )
                
                (if empty_biglist_flag
                    (set! flattened_list '())
                )
            )
            
            (begin
                (test:equal #t #f "argument is not a list")
            )
        )
    flattened_list
    )
)

; e.g. (flatlist (map tolerant:report (part:entities)))
; e.g. (flatlist (map entity:check (part:entities)))

;************************************************************************************************************
; Visualize api_ray_fire results
;************************************************************************************************************
(define rainbow
  (list
    rgb:red     
    rgb:cyan    
    rgb:yellow  
    rgb:magenta 
    rgb:green   
    rgb:orange  
    rgb:blue    
  )
)
(define (ray_hit_list_visualize . args)
    (printf "The order is: Red, Cyan, Yellow, Magenta, Green, Orange, Blue, repeat...")
    (define hits '())
    (define remove_colors #f)
    (do ((a args (cdr a))) ((null? a)) ; See if a ray is defined using ray or (position and gvector)...
      (begin
        (define arg (car a))
        (if (symbol? arg) (set! arg (symbol->string arg))) ; In order to process strings and quote expressions the same.
        (cond
            ( (list? arg)     (set! hits arg) )
            ( (boolean? arg) (set! remove_colors arg) )
        )
      )
    )
    ;Visualize the hits by coloring the entities hit
    (if remove_colors
      (begin
        (entity:remove-colors) ; Remove colors from all entities
        (env:set-default-color(color:rgb 0.5 0.5 0.5)) ; Set default color to a mid gray
        (render:rebuild) ; Update HOOPS display
      )
    )
    (if (equal? 0 (length (env:views)))
      (begin
        (view:gl 0 0 500 500)
        (view:edges #t)
        (zoom-all)
        (iso)
      )
    )
    (define return_list '())
    (define color_index 0)
    (if (not (equal? '() env:views)) (map 
      (lambda (hit)
        (define my_color (list-ref rainbow (modulo color_index (length rainbow))))
        (entity:set-color (car hit) my_color)
        ;Visualize the hits with colored '+'s along the ray
        (define ro1 (ro:point (list-ref hit 4)))
        (ro:set-color ro1 my_color)
        ;Visualize the hits with colored 'O's on the entities
        (define ro2 (ro:point (list-ref hit 2)))
        (ro:set-color ro2 my_color)
        (ro:set-marker-symbol ro2 'O)
        (ro:set-marker-size ro2 1) 
        ;Visualize the hits with colored lines between the ray and the entities
        (define ro3 (ro:line (list-ref hit 4) (list-ref hit 2)))
        (ro:set-color ro3 my_color)
        (set! color_index (+ 1 color_index))
        (set! return_list (append return_list (list (list ro1 ro2 ro3))))
      )
      hits
    ) )
    (view:refresh)
    return_list
)

;************************************************************************************************************
; Print solid:ray-fire results
;************************************************************************************************************
(define (ray_hit_list_print hit_list)
    (for-each
        (lambda (hit)
            (printf "entity_type_hit = ~a" (entity:debug (list-ref hit 0)) )
            (printf "\t entity     = ~a" (list-ref hit 0) ) ;           (car hit)                (caar hit_list)
            (printf "\t entity_uv  = ~a" (list-ref hit 1) ) ;          (cadr hit)               (cadar hit_list)
            (printf "\t entity_pos = ~a" (list-ref hit 2) ) ;         (caddr hit)              (caddar hit_list)
            (printf "\t ray_param  = ~a" (list-ref hit 3) ) ;        (cadddr hit)         (car (cdddar hit_list))
            (printf "\t ray_pos    = ~a" (list-ref hit 4) ) ;   (cadr (cdddr hit))       (cadr (cdddar hit_list))
            (printf "\t hit_type   = ~a" (list-ref hit 5) ) ;  (caddr (cdddr hit))      (caddr (cdddar hit_list))
            (printf "\t ray_surf_rel=~a" (list-ref hit 6) ) ; (cadddr (cdddr hit))      (caddr (cdddar hit_list))
        )
        hit_list
    )
)

(define (ray:test . args)
  (begin
    (define hits (apply solid:ray-fire (append (list "list") args) ) )
    (ray_hit_list_print hits)
    hits
  )
)

(define (api_ray_test . args)           (apply solid:ray-fire (append (list "list") args) ) )
;;-------------------------------------------------------------------------------------------------------------------------------------;;

(define (env:use-fileinfo . args)  (begin
    (define verbose #t)
	(define ret_value #f)
    (do ((a args (cdr a))) ((null? a))
        (if (or (entity? (car a)) (entity-list? (car a)) )   (set! ents (car a)) )
        (define arg (car a))
        (if (symbol? arg) (set! arg (symbol->string arg))) ; In order to process strings and quote expressions easier
        (if (and (string? arg) (equal? arg "q") )   (set! verbose #f) )
        (if (and (string? arg) (equal? arg "v") )   (set! verbose #t) )
    )
	(define old_resabs (car  (env:tolerance)))
	(define old_resnor (cadr (env:tolerance)))
	(define old_resfit (caddr(env:tolerance)))
	(define new_resabs (car  (env:restored-tolerances)))
	(define new_resnor (cadr (env:restored-tolerances)))
	(if (or (not (= old_resabs new_resabs)) (not (= old_resnor new_resnor)))  (begin
		(set! ret_value #t)
		(if verbose (printf "File's tolerances: ~a" (env:restored-tolerances)))
		(if verbose (printf "Current tolerances: ~a" (env:tolerance)))
		(env:set-tolerance new_resabs new_resnor ( * (/ new_resabs old_resabs) old_resfit) #t)
		(if verbose (printf "Revised tolerances: ~a" (env:tolerance)))
	) )
	(if (not (= (env:restored-units-scale) (env:save-units-scale)))  (begin
		(if verbose (printf "File's save units: ~a" (env:restored-units-scale)))
		(if verbose (printf "Current save units: ~a" (env:save-units-scale)))
		(env:set-save-units-scale (env:restored-units-scale))
		(if verbose (printf "Revised save units: ~a" (env:save-units-scale)))
	) )
	ret_value
) )

(define line_list (lambda (filename)
    (let ((p (open-input-file filename)))
        (let f ((x (read-line p)))
            (if (eof-object? x) (begin
                (close-input-port p)
                '()
            ) ; else
                (cons x (f (read p)))
            )
        )
    )
) )

(define substring_to_last_char (lambda (in_str in_char)
    (define retval "")
    (define strlen (string-length in_str))
    (do (( i (- strlen 1) (- i 1) ) )  ( (< i 0) i)
        (if (char=? (string-ref in_str i) in_char) (begin
            (set! retval (substring in_str 0 i) )
            (set! i 0) ; exit out of loop
        ) )
    )
    retval
) )

(define (string-replace-ci strIn strReplace strReplaceWith)
    (let*
        (
            (replaceLen (string-length strReplace))
            (replaceWithLen (string-length strReplaceWith))
            (inLen (string-length strIn))
            (result strIn)
        )
        ;loop through the main string searching for the substring
        (do ((curIndex 0 (+ curIndex 1))) ((> (+ curIndex replaceLen) inLen) result)
            ;check to see if the substring is a match
            (if (string-ci=? strReplace (substring result curIndex (+ curIndex replaceLen)))
                (begin
                    ;create the result string
                    (set! result (string-append (substring result 0 curIndex) strReplaceWith (substring result (+ curIndex replaceLen) inLen)))
                    ;now set the current index to the end of the replacement. it will get incremented below so take 1 away so we don't miss anything
                    (set! curIndex (-(+ curIndex replaceWithLen) 1))
                    ;set new length for inLen so we can accurately grab what we need
                    (set! inLen (string-length result))
                )
            )
		)
    )
)

(define script_name (lambda ()
    (define retval (system:getenv "SPA_TEST_NAME"))
    retval
) )

(define script_dir (lambda ()
    (define retval (string-append (substring_to_last_char (system:getenv "SPA_TEST_NAME") #\/) ) )
    ( if (or (= 0 (string-length retval) )  (not (char=? (string-ref retval 0) #\/) ) ) 
        (if (or (= 0 (string-length retval) )  (not (char=? (string-ref retval 0) #\/) ) )
            ( if (or (= 0 (string-length retval) )  (not (char=? (string-ref retval 1) #\:) ) )
                (begin
                    (system:command "pwd > SCHEME_TEMP_FILE")
                    (define script (car (line_list 'SCHEME_TEMP_FILE) ) )
                    (system:command "del SCHEME_TEMP_FILE")
                    ;(set! retval (string-append (substring_to_last_char script #\/) ) )
                    (set! retval (string-append script "/") )
                    ;(set! retval script)
    )   )   )   )
    retval
) )

;(define cmd	; Runs the specified command and returns first line of stdout/stderr
;  (lambda ( arg )	; Enhance with multiple arguments: first and last line numbers, ...
;	(define filename "SCHEME_TEMP_FILE")
;    (system:command (string-append arg " > " filename))
;	(define retval #f)
;    (if (file-exists? filename)
;	  (begin
;		(define filename_output (line_list filename))
;		(if (and (list? filename_output) (< 0 (length filename_output))) (set! retval (car filename_output)))
;		(system:command (string-append "del " filename))
;	  )
;	)
;    retval
;  )
;)

(define hostname "")
(define (env:hostname)
	(if (string=? "" hostname)
		(define hostname (if (string=? (system:name) "mac") "Macintosh" (cmd "hostname")))
	)
	hostname
)

(if (bound? 'system:cpu-speed)
	(define hostspeed (round_number (/ (system:cpu-speed) 1000) -3))
	;else
	(define hostspeed 0.001) ; Default is 1 MHz, indicating that CPU_speed is unknown (and won't cause a /0 FPE)
)

(define (env:app_info)
	;(printf "Host name: ~a. Host speed ~a GHz" (env:hostname) hostspeed)
	(list-print (system:getenv ">"))
	(newline)
)

(define (performance op_string baseline_time baseline_hostspeed operation_time . args) ; Check performance to a known baseline
  ; op_string is the operation, i.e. "facet", "thicken", "unite", "intersect", "wrap", etcetera.
  ; Record the baseline on a 64-bit release build (not IDC or ML), and not on a Virtual Machine, like DT7-GRF-9SPA.
  ; baseline_time is a double-precision number in seconds . You may want to note the date the baseline was calculated.
  ; baseline_hostspeed is the CPU_speed.  DT7-GRF-9SPA runs at 2.39 GHz.  Use (system:cpu-speed) (MHz) on the machine the baseline is calculated on.
  ; operation_time is the current time it takes to complete the operation (such as faceting, thickening, etc).
	(define slop_factor  1.10) ; Add 10% for fluctuation
	(define VM_factor    1.25) ; Windows VM can be 25% slower than Windows non-VM
	(define Linux_factor 1.75)	; Linux VM can be 75% slower than Windows non-VM
	(define Mac_factor   3.00) ; Macintosh can be 200% (3 times) slower than Windows non-VM
	(define 32bit_factor 1.25) ; 32bit can be 25% slower than 64bit.
	(define VC15_factor  2.00) ; VC15 can be 100% (2 times) slower than VC14.  This may change in the near future.
	(define error #f)
	(define return_value #f)
	(if (list? args)
	  (do ((a args (cdr a))) ((null? a))
		(define arg (car a))
		(if (symbol? arg) (set! arg (symbol->string arg))) ; In order to process strings and quote expressions the same.
		(cond
			((string? arg)
				(cond
					((equal? arg "slop")	(set! slop_factor	(cadr a)) (set! a (cdr a)) )
					((equal? arg "VM")		(set! VM_factor		(cadr a)) (set! a (cdr a)) )
					((equal? arg "Linux")	(set! Linux_factor	(cadr a)) (set! a (cdr a)) )
					((equal? arg "Mac")	(set! Mac_factor	(cadr a)) (set! a (cdr a)) )
					((equal? arg "32bit")	(set! 32bit_factor	(cadr a)) (set! a (cdr a)) )
					((equal? arg "VC15")	(set! VC15_factor	(cadr a)) (set! a (cdr a)) )
					(else (set! error #t)	(printf "*** Error: unrecognized string argument") )
				)
			)
			(else (set! error #t) (printf "*** Error: unrecognized argument type") )
		)
      )
	)
	(if (not (or error (< baseline_time 0) (is-debug-build?) (is-idc-build?)))
	  (begin
		; Estimated time is inversely proportional to CPU-speed.
		; It would be better to know the count of VM swaps of memory (and CPU)
		(define est_time (/ (* baseline_time baseline_hostspeed) hostspeed))
		(if (is-windows-build?)
		  (begin ; VM machines run slower than developer's machines
			(if (and (symbol? 'system:get-compiler-info) (<= 1910 (cadar (system:get-compiler-info))))
				(set! est_time (* est_time VC15_factor))		
			)
			(if (env:vmware?) (set! est_time (* est_time VM_factor)))
			(if (not (is-64bit-build?)) (set! est_time (* est_time 32bit_factor)))
		  ) ; Increasing for 32-bit (thunking?)? Maybe we should add, not multiply, 32 factor with VM factor? Meh.
		;else it is Linux or Macintosh
		  (begin
			(if (string=? (system:name) "mac")
				(set! est_time (* est_time Mac_factor)) ; Macintosh VM machine
			; else
				(set! est_time (* est_time Linux_factor)) ; Unix or Linux VM machine
			)
		  ) ; The GHz on Linux and Mac does not correspond to Window's GHz at all.
		)
		(define allowed_time (* est_time slop_factor)) ; Add for fluctuation (slop)
		(printf "Actual   time = ~a CPU_seconds on this platform." (round_number operation_time -3))
		(printf "Baseline time = ~a CPU_seconds at ~a GHz" baseline_time baseline_hostspeed)
		(printf "Allowed  time = ~a CPU_seconds (~a * ~a fluctuation)."
				(round_number allowed_time -3) (round_number est_time -3) (round_number slop_factor -3))
		(define error_text (string-append "Slow to " op_string " at " (number->string hostspeed) " GHz"))
		(set! return_value (test:less-than operation_time allowed_time error_text))
		(if return_value (printf "Time to ~a:  ~a CPU_seconds." op_string (round_number operation_time -3)))
		(system:command (string-append "echo " (number->string operation_time) ", CPU_seconds to " op_string ".> perf.log") )
	  )
	;else we don't do performance monitoring
		(printf "Performance monitoring is not relevant on this platform.")
	)
	return_value
)

(define (save_hit_list hit_list output-filename)
	(define out (open-output-file output-filename))
	(for-each
		(lambda (hit)
			(format out "\nentity_type_hit = ~a\n" (entity:debug (list-ref hit 0)))
			(format out "\t entity     = ~a\n" (list-ref hit 0))	;           (car hit)
			(format out "\t entity_uv  = ~a\n" (list-ref hit 1))	;          (cadr hit)
			(format out "\t entity_pos = ~a\n" (list-ref hit 2) )	;         (caddr hit)
			(format out "\t ray_param  = ~a\n" (list-ref hit 3) )	;        (cadddr hit)
			(format out "\t ray_pos    = ~a\n" (list-ref hit 4) )	;   (cadr (cdddr hit))
			(format out "\t hit_type   = ~a\n" (list-ref hit 5) )	;  (caddr (cdddr hit))
			(format out "\t ray_surf_rel=~a" (list-ref hit 6) )	; (cadddr (cdddr hit))
		)
		hit_list
	)
	(flush-output-port out)
	(close-output-port out)
)

;;-------------------------------------------------------------------------------------------------------------------------------------;;
;This function creates a wire block. It takes the lower left corner and the upper right corner of the block as it's arguments.
;example (wire:block 0 0 0 1000 1000 1000) 

(define (wire:block x1 y1 z1 x2 y2 z2)
	(begin
		(view:edges ON)
		(define retList '())
		;
		(define V1 (position x1 y1 z1))
		(define V2 (position x2 y1 z1))
		(define V3 (position x2 y1 z2))
		(define V4 (position x1 y1 z2))
		(define V5 (position x2 y2 z1))
		(define V6 (position x2 y2 z2))
		(define V7 (position x1 y2 z2))
		(define V8 (position x1 y2 z1))
		;
		(set! retList (cons (edge:linear V1 V2) retList))
		(set! retList (cons (edge:linear V2 V3) retList))
		(set! retList (cons (edge:linear V3 V4) retList))
		(set! retList (cons (edge:linear V4 V1) retList))
		(set! retList (cons (edge:linear V5 V6) retList))
		(set! retList (cons (edge:linear V6 V7) retList))
		(set! retList (cons (edge:linear V7 V8) retList))
		(set! retList (cons (edge:linear V8 V5) retList))
		(set! retList (cons (edge:linear V1 V8) retList))
		(set! retList (cons (edge:linear V2 V5) retList))
		(set! retList (cons (edge:linear V3 V6) retList))
		(set! retList (cons (edge:linear V4 V7) retList))
		(set! retList (wire-body:group retList))
		(set! retList (bool:unite retList))
		(zoom-all)
	)
	retList
)

;;-------------------------------------------------------------------------------------------------------------------------------------;;

;This function creates a 3D array of the given entity. Arguments are- 
; Entity, LL (lower left corner) of the bounding box, 
; UR (upper right corner) of the bounding box, 
; instances in X direction, instances in Y direction, instances in Z direction
; Example (entity:array block 0 0 0 100 100 100 2 3 4)
; Help for calculating the LL and UR for the bounding box is given below-
;In case of a BLOCK, the length, breadth and height of the block has to be 
; subtracted from the length, breadth and height of the bounding box while 
; calling entity:array
;In case of a SPHERE, the origin should be such that the sphere is
; tangent to the bounding box (0+r,0+r,0+r). The diameter(2r) of the sphere 
; should be subtracted from the length, breadth and height of 
; the bounding box while calling entity:array
;In case of TORUS, the origin should be such that the torus is 
; tangent to the bounding box (0+R_maj+R_min,0+R_maj+R_min,0+R_maj+R_min). 
; 2R_maj + 2R_min should be subtracted from the length, breadth and height
; of the bounding box while calling entity:array
;In case of CYLINDER, origin should be at (r, r, 0). 2r should be subtracted 
; from length and breadth of the bounding box and 
; height of cyl to subtracted from height of bounding box.
;In case of CONE, origin should be at (r, r, 0). 
; 2r should be subtracted from length and breadth of the bounding box 
; and height of cone to subtracted from height of bounding box.
;In case of WIGGLE, move it to the point ((l/2) (b/2) (h/2))
; Subtract the length, breadth, height of the wiggle from the 
; length, breadth, height of the bounding box while calling entity:array
(define (entity:array Ent x1 y1 z1 x2 y2 z2 inst_x inst_y inst_z)
	(define org_x x1)
	(define org_y y1)
	(define org_z z1)
	; Move Ent to x1 y1 z1
	; Calculate x_spacing
	(define x_spacing (/ (- x2 x1 ) (- inst_x 1)))
	(print (format #t "x_spacing = ~s" x_spacing))
	; Calculate y_spacing
	(define y_spacing (/ (- y2 y1 ) (- inst_y 1)))
	(print (format #t "y_spacing = ~s" y_spacing))
	; Calculate z_spacing
	(define z_spacing (/ (- z2 z1 ) (- inst_z 1)))
	(print (format #t "z_spacing = ~s" z_spacing))

	(do ((z-axis 0 (+ z-axis 1))) ((= z-axis inst_z))
		(begin
			(do ((y-axis 0 (+ y-axis  1))) ((= y-axis  inst_y))
				(begin
					(do ((x-axis 0 (+ x-axis 1))) ((= x-axis inst_x))
						(begin
							(define c_x (* z-axis z_spacing))
							(define c_y (* y-axis y_spacing))
							(define c_z (* x-axis x_spacing))
							;(print (format #t "\n coordianates : ~s ~s ~s" (+ x1 c_x) (+ y1 c_y) (+ z1 c_z)))
							(entity:move (entity:copy Ent) (+ x1 c_x) (+ y1 c_y) (+ z1 c_z) #t)
						)
					)
				)
			)
		)
	)
	(entity:delete Ent)
)

(define (relation . args)
  (define retval '())
  (define verbose #t)
  (begin	;; Prints the relationship between an EDGE and a FACE
    (define edge '())
	(define face '())
    (do ((a args (cdr a))) ((null? a))
        (define arg (car a))
        (if (symbol? arg) (set! arg (symbol->string arg))) ; In order to process strings and quote expressions the same.
        (cond
            ( (edge? arg) (set! edge arg) )
            ( (face? arg) (set! face arg) )
			(if (and (string? arg) (equal? arg "q") )   (set! verbose #f) )
			(if (and (string? arg) (equal? arg "v") )   (set! verbose #t) )
        )
    )
	(if (not (and (null? edge) (null? face)))
	  (begin
		(set! retval (edge:entity-rel edge face)) ; When (edge:entity-rel) crashes, retval is not changed.
		(if (list? retval)
			(for-each (lambda (entry) (printf "  ~a" entry )) retval)
			(printf "  ~a" retval)
		)
	  )
	)
  )
  retval
)

(define random-float (lambda (minn maxn)
    ; Generate a random real number between minn and maxn, inclusive.
    (+ (* (/ (modulo (random) 32768) 32767) (- maxn minn) ) minn)
) )

(define (entity:set-color-randomly . args) (begin
    (define in_ents '())
	(define bodies #f)
	(define color_range_start '())
	(define color_range_end   '())
    (do ((a args (cdr a))) ((null? a))
        (define arg (car a))
        (if (symbol? arg) (set! arg (symbol->string arg))) ; In order to process strings and quote expressions the same.
        (cond
            ((or (entity? arg) (entity-list? arg)) (set! in_ents arg))
			((and (real? arg) (null? color_range_start))   (set! color_range_start arg))
			((and (real? arg) (null? color_range_end))     (set! color_range_end arg))
        )
    )
    (if (null? in_ents)  (set! in_ents (part:entities)) )
	(if (null? color_range_start) (set! color_range_start .1))
	(if (null? color_range_end)   (set! color_range_end   .9))
    (define ents in_ents)
    (define red   (random-float color_range_start color_range_end))
    (define green (random-float color_range_start color_range_end))
    (define blue  (random-float color_range_start color_range_end))
    (do ((i 1 (+ i 1))) ((> i (length ents))) 
        (begin 
            (set! red   (random-float color_range_start color_range_end))
            (set! green (random-float color_range_start color_range_end))
            (set! blue  (random-float color_range_start color_range_end))
            (entity:set-color (list-ref ents (- i 1)) (color:rgb red green blue) )
        )   
    )
) )

(define (view:vertex-tol my_vert)
    (define pos (vertex:position my_vert))
    (if (member my_vert (entity:tvertices (part:entities)))
		(if (> (vertex:get-tolerance my_vert) (car (env:tolerance)))
			(solid:sphere (position:x pos) (position:y pos) (position:z pos)  (vertex:get-tolerance my_vert))
		)
    )
)

(define (view:edge-tol my_edge)
    (if (member my_edge (entity:tedges (part:entities))) (and (> (edge:get-tolerance my_edge) (car (env:tolerance)))
			(begin
				(define profile (edge:ellipse (edge:start my_edge) (edge:start-dir my_edge)  (edge:get-tolerance my_edge) ))
				(sweep:law profile my_edge)
			)
		)
	)
)

(define (view:flat)
	(begin
		(hoops:set_rendering_options "lighting interpolation = flat")
		(render:rebuild)
	)
)

(define refinements_helper (lambda (elist)
    (define all_refs (eelist:new))
    (define face_list (entity:faces elist))
    (map
        (lambda (face)
            (define str1 "\n")
            (define faceref (entity:refinement face))
            (define ref #f)
            (if (not (eq? faceref #f)) (begin
                (set! str1 (format #f "Face~a: ref=~a " face faceref))
                (eelist:add all_refs faceref)
            ) )
            (define sub_list (entity:shells face))
            (if (not (null? sub_list)) (begin
                (set! ref (entity:refinement (car sub_list)))
                (if (not (eq? ref #f)) (begin
                    (if (not faceref) (set! str1 (format #f "Face~a: " face)) (format #f "~a, " str1) )
                    (set! str1 (format #f "~aShell~a: ref=~a " str1 (car sub_list) ref))
                    (eelist:add all_refs ref)
            ) ) ) )
            (define sub_list (entity:lumps face))
            (if (not (null? sub_list)) (begin
                (set! ref (entity:refinement (car sub_list)))
                (if (not (eq? ref #f)) (begin
                    (if (not faceref) (set! str1 (format #f "Face~a: " face)) (format #f "~a, " str1) )
                    (set! str1 (format #f "~aLump~a: ref=~a " str1 (car sub_list) ref))
                    (eelist:add all_refs ref)
            ) ) ) )
            (define body (filter:apply (filter:type "body?") (entity:owner face) ) )
            (if (not (null? body)) (begin
                (set! ref (entity:refinement (car body)))
                (if (not (eq? ref #f)) (begin
                    (if (not faceref) (set! str1 (format #f "Face~a: " face)) (format #f "~a, " str1) )
                    (set! str1 (format #f "~aBody~a: ref=~a " str1 (car sub_list) ref))
                    (eelist:add all_refs ref)
            ) ) ) )
            (if (< 2 (string-length str1)) (printf str1) )
        )
        face_list
    )
    (define retval (reverse (eelist:entities all_refs)))
    (entity:delete all_refs)
    retval
) )
(define (refinements . args) (begin ; Use (part:entities) if first arg is not an entity or a list of entities
    (define params '())
    (if (null? args)
      (begin
        (set! params (part:entities))
      ) ; else
      (begin
        (if (or (entity? (car args)) (entity-list? (car args)))
            (set! params args)
            (set! params (append params (list (part:entities)) args))
        )
      )
    )
    (refinements_helper params)
) )
;;-------------------------------------------------------------------------------------------------------------------------------------;;

